关于Delphi通用涵数

    技术2022-05-11  2

                                          DELPHI程序注册码设计(转载)     思路是这样的:程序运行时先检测注册表,如果找到注册项,则表明已经注册,如果没有找到注册项,则提示要求注册.         <注册例程>         在DELPHI下新建一工程,放置Edit1,Edit2,Label1,Label2,Button1组件.具体代码如下:         unit   Unit1;         interface         uses     Windows,   Messages,   SysUtils,   Classes,   Graphics,   Controls,   Forms,   Dialogs,     StdCtrls,Registry;//在此加上Registry以便调用注册表.         type     TForm1   =   class(Tform)     Button1:   Tbutton;     Edit1:   Tedit;     Edit2:   Tedit;     Label1:   Tlabel;     Label2:   Tlabel;     procedure   Button1Click(Sender:   Tobject);     procedure   FormCreate(Sender:   Tobject);     private     Function   Check():Boolean;     Procedure   CheckReg();     Procedure   CreateReg();     {   Private   declarations   }     public     {   Public   declarations   }     end;         var     Form1:   TForm1;     Pname:string;   //全局变量,存放用户名和注册码.     Ppass:integer;         implementation         {$R   *.DFM}         Procedure   TForm1.CreateReg();//创建用户信息.     var   Rego:Tregistry;     begin     Rego:=Tregistry.Create;     Rego.RootKey:=HKEY_USERS;     rego.OpenKey(‘.DEFAULTSoftwareAngelSoftDemo‘,True);//键名为AngelSoftDemo,可自行修改.     Rego.WriteString(‘Name‘,Pname);//写入用户名.     Rego.WriteInteger(‘Pass‘,Ppass);//写入注册码.     Rego.Free;     ShowMessage(‘程序已经注册,谢谢!‘);     CheckReg;   //刷新.     end;         Procedure   TForm1.CheckReg();//检查程序是否在注册表中注册.     var   Rego:Tregistry;     begin     Rego:=Tregistry.Create;     Rego.RootKey:=HKEY_USERS;     IF   Rego.OpenKey(‘.DEFAULTSoftwareAngelSoftDemo‘,False)   then     begin     Form1.Caption:=‘软件已经注册‘;     Button1.Enabled:=false;     Label1.Caption:=rego.ReadString(‘Name‘);//读用户名.     Label2.Caption:=IntToStr(Rego.ReadInteger(‘Pass‘));   //读注册码.     rego.Free;     end     else   Form1.Caption:=‘软件未注册,请注册‘;     end;         Function   TForm1.Check():Boolean;//检查注册码是否正确.     var     Temp:pchar;     Name:string;     c:char;     I,Long,Pass:integer;     begin     Pass:=0;     Name:=edit1.Text;     long:=length(Name);         for   I:=1   to   Long   do     begin     temp:=pchar(copy(Name,I,1));     c:=temp^;     Pass:=Pass+ord(c);   //将用户名每个字符转换为ASCII码后相加.     end;     if   StrToInt(Edit2.Text)=pass   then     begin     Result:=True;     Pname:=Name;     Ppass:=Pass;     end     else   Result:=False;     end;         procedure   TForm1.Button1Click(Sender:   Tobject);     begin     if   Check   then   CreateReg     else   ShowMessage(‘注册码不正确,无法注册‘);     end;         procedure   TForm1.FormCreate(Sender:   Tobject);     begin     CheckReg;     end;         end.             <注册器>         在DELPHI下新建一工程,放置Edit1,Edit2,Button1组件.具体代码如下:         unit   Unit1;         interface         uses     Windows,   Messages,   SysUtils,   Classes,   Graphics,   Controls,   Forms,   Dialogs,     StdCtrls;         type     TForm1   =   class(Tform)     Button1:   Tbutton;     Edit1:   Tedit;     Edit2:   Tedit;     procedure   Button1Click(Sender:   Tobject);     private     {   Private   declarations   }     public     {   Public   declarations   }     end;         var     Form1:   TForm1;         implementation         {$R   *.DFM}         procedure   TForm1.Button1Click(Sender:   Tobject);     var     Temp:pchar;     Name:string;     c:char;     I,Long,Pass:integer;     begin     Pass:=0;     Name:=edit1.Text;     long:=length(Name);         for   I:=1   to   Long   do     begin     temp:=pchar(copy(Name,I,1));     c:=temp^;     Pass:=Pass+ord(c);     end;     edit2.text:=IntToStr(pass);     end;         end.         从<注册器>中取得注册码,便可在<注册例程>中进行注册.原理是使用ORD函数取得用户名每单个字符的ASCII码值,并进行相加得到注册码.    

     

    function     FilterNumber(keyval:   char;   me:   TEdit;   dot,   Minus:   string;   ExtLen:   integer):   boolean;     var           s:   string;           c:   string;           p:   Integer;     begin                 result   :=   false;             s   :=   '0123456789';             c   :=   keyval;             if   (dot   =   '.')   then                     s   :=   s   +   '.';             if   (minus   =   '-')   then                     s   :=   s   +   '-';             if   (c   =   dot)   and   (TRIM(me.text)   =   '')   then                     Exit;             if   (c   =   dot)   and   (Pos(dot,   me.text)   >   0)   then                     Exit;             if   (c   =   dot)   and   (trim(me.text)   =   minus)   then                     Exit;             if   (c   =   minus)   and   (Pos(minus,   me.Text)   >   0)   then                     Exit;             if   (c   =   minus)   and   (pos(minus,   me.Text)   <   1)   and   (Me.SelStart   >   0)   then                     Exit;             if   (c   =   minus)   and   (trim(me.Text)   =   dot)   then                     Exit;             result   :=   (keyval   =   chr(vk_return))   or   (keyval   =   Chr(vk_tab))                     or   (keyval   =   chr(VK_DELETE))   or   (keyval   =   chr(VK_BACK))   or   (Pos(c,   s)   >   0);             p   :=   Pos(dot,   Me.Text   +   c);             if   (p   >   0)   then                     if   (length(Me.text   +   c)   -   P)   >   ExtLen   then                             result   :=   (false)   or   (keyval   =   chr(vk_return))   or   (keyval   =   Chr(vk_tab))                                     or   (keyval   =   chr(VK_DELETE))   or   (keyval   =   chr(VK_BACK));     end;         procedure   TForm1.Edit1KeyPress(Sender:   TObject;   var   Key:   Char);     begin             if   not   filterNumber(key,   Edit1,   '.',   '-',   6)   then                     key   :=   #0;     end;    

    Top

    //如何用代码自动建ODBC         以下是在程序中动态创建ODBC的DSN数据源代码:       procedure   TCreateODBCDSNfrm.CreateDSNBtnClick(Sender:   TObject);       var           registerTemp   :   TRegistry;           bData   :   array[   0..0   ]   of   byte;       begin           registerTemp   :=   TRegistry.Create;           //建立一个Registry实例           with   registerTemp   do                     begin                   RootKey:=HKEY_LOCAL_MACHINE;                   //设置根键值为HKEY_LOCAL_MACHINE                   //找到Software/ODBC/ODBC.INI/ODBC   Data   Sources                   if   OpenKey('Software/ODBC/ODBC.INI                   /ODBC   Data   Sources',True)   then                 begin   //注册一个DSN名称                 WriteString(   'MyAccess',   'Microsoft                   Access   Driver   (*.mdb)'   );                             end                         else                             begin//创建键值失败                 memo1.lines.add('增加ODBC数据源失败');                 exit;                   end;                   CloseKey;       //找到或创建Software/ODBC/ODBC.INI         /MyAccess,写入DSN配置信息                   if   OpenKey('Software/ODBC/ODBC.INI                   /MyAccess',True)   then                 begin                 WriteString(   'DBQ',   'C:/inetpub/wwwroot                 /test.mdb'   );//数据库目录,连接您的数据库                 WriteString(   'Description',                 '我的新数据源'   );//数据源描述                 WriteString(   'Driver',   'C:/PWIN98/SYSTEM/                 odbcjt32.dll'   );//驱动程序DLL文件                 WriteInteger(   'DriverId',   25   );                 //驱动程序标识                 WriteString(   'FIL',   'Ms   Access;'   );                 //Filter依据                 WriteInteger(   'SafeTransaction',   0   );                 //支持的事务操作数目                 WriteString(   'UID',   ''   );//用户名称                 bData[0]   :=   0;                 WriteBinaryData(   'Exclusive',   bData,   1   );                 //非独占方式                 WriteBinaryData(   'ReadOnly',   bData,   1   );                 //非只读方式                             end                         else//创建键值失败                             begin                 memo1.lines.add('增加ODBC数据源失败');                 exit;                   end;                   CloseKey;       //找到或创建Software/ODBC/ODBC.INI       /MyAccess/Engines/Jet               //写入DSN数据库引擎配置信息                   if   OpenKey('Software/ODBC/ODBC.INI                 /MyAccess/Engines/Jet',True)   then                 begin                 WriteString(   'ImplicitCommitSync',   'Yes'   );                 WriteInteger(   'MaxBufferSize',   512   );//缓冲区大小                 WriteInteger(   'PageTimeout',   10   );//页超时                 WriteInteger(   'Threads',   3   );//支持的线程数目                 WriteString(   'UserCommitSync',   'Yes'   );                             end                         else//创建键值失败                             begin                 memo1.lines.add('增加ODBC数据源失败');                 exit;                   end;                   CloseKey;                         memo1.lines.add('增加新ODBC数据源成功');                   Free;                     end;       end;

    一个管理最近使用过的文件的类:         {-----------------------------------------------------------------------------       Unit   Name:   RcntFileMgr       Author:         tony       Purpose:       Manager   the   recent   file   list.       History:       2004.06.08         create     -----------------------------------------------------------------------------}             unit   RcntFileMgr;         interface         uses         Classes,   SysUtils,   Inifiles;         type         TRecentFileChangedEvent   =   procedure(Sender:TObject)   of   object;                 TRecentFileManager=class(TObject)         private             FRecentFileList:TStringList;             FMaxRecentCount:Integer;             FOnRecentFileChanged:TRecentFileChangedEvent;         protected             function   GetRecentFileCount():Integer;             function   GetRecentFile(Index:Integer):String;             procedure   LoadFromConfigFile();             procedure   SaveToConfigFile();         public             constructor   Create();             destructor   Destroy();override;             procedure   AddRecentFile(const   AFileName:String);             property   RecentFileCount:Integer   read   GetRecentFileCount;             property   RecentFile[Index:Integer]:String   read   GetRecentFile;             property   OnRecentFileChanged:TRecentFileChangedEvent   read   FOnRecentFileChanged   write   FOnRecentFileChanged;         end;             implementation         {   TRecentFileManager   }         function   TRecentFileManager.GetRecentFileCount():Integer;     begin         Result:=FRecentFileList.Count;     end;         function   TRecentFileManager.GetRecentFile(Index:Integer):String;     begin         Result:=FRecentFileList.Strings[Index];     end;         procedure   TRecentFileManager.LoadFromConfigFile();     var         Ini:TInifile;         KeyList:TStringList;         I:Integer;     begin         Ini:=TInifile.Create(ExtractFilePath(ParamStr(0))+'config.ini');         KeyList:=TStringList.Create();         try             Ini.ReadSection('RecentFile',KeyList);             for   I:=0   to   KeyList.Count-1   do   begin                 FRecentFileList.Add(Ini.ReadString('RecentFile',KeyList.Strings[I],''));             end;             if   Assigned(FOnRecentFileChanged)   then   begin                 FOnRecentFileChanged(self);             end;         finally             Ini.Free;             KeyList.Free;         end;     end;         procedure   TRecentFileManager.SaveToConfigFile();     var         Ini:TInifile;         I:Integer;     begin         Ini:=TInifile.Create(ExtractFilePath(ParamStr(0))+'config.ini');         try             Ini.EraseSection('RecentFile');             for   I:=0   to   FRecentFileList.Count-1   do   begin                 Ini.WriteString('RecentFile','Recent'+IntToStr(I),FRecentFileList.Strings[I]);             end;         finally             Ini.Free;         end;     end;         constructor   TRecentFileManager.Create();     begin         inherited   Create();         FRecentFileList:=TStringList.Create();         FMaxRecentCount:=5;         LoadFromConfigFile();     end;         destructor   TRecentFileManager.Destroy();     begin         if   Assigned(FRecentFileList)   then   begin             try                 SaveToConfigFile();             except                 //ignore   any   exceptions             end;             FreeAndNil(FRecentFileList);         end;         inherited   Destroy();     end;         procedure   TRecentFileManager.AddRecentFile(const   AFileName:String);     var         RecentIndex:Integer;     begin         RecentIndex:=FRecentFileList.IndexOf(AFileName);         if   RecentIndex>=0   then   begin             FRecentFileList.Delete(RecentIndex);         end;         FRecentFileList.Insert(0,AFileName);         while   FRecentFileList.Count>FMaxRecentCount   do   begin             FRecentFileList.Delete(FRecentFileList.Count-1);         end;         if   Assigned(FOnRecentFileChanged)   then   begin             FOnRecentFileChanged(self);         end;     end;         end.    

    Top9楼  tonylk   (=www.tonixsoft.com=)   回复于 2004-07-20 15:55:46  得分 0

    一个SDI类型的文件管理器,可以管理新建,保存,另存为,以及关闭时提示保存等功能:     unit   FileMgr;         interface         uses         Windows,   Messages,   SysUtils,   Variants,   Classes,   Forms,   Controls,   Dialogs,         QuickWizardFrm,   TLMObject;         type         TNewFileEvent   =   procedure   (Sender:TObject;var   Successful:Boolean)   of   object;         TStartWizardEvent   =   procedure   (Sender:TObject;Info:TQuickWizardInfo;var   Successful:Boolean)   of   object;         TOpenFileEvent   =   procedure   (Sender:TObject;const   FileName:String;var                           Successful:Boolean)   of   object;         TSaveFileEvent   =   procedure   (Sender:TObject;const   FileName:String;var                           Successful:Boolean)   of   object;         TCloseFileEvent   =   procedure   (Sender:TObject;var   Successful:Boolean)   of   object;         TFileNameChangedEvent   =   procedure   (Sender:TObject;const   FileName:String)   of                           object;         TFileManager   =   class   (TObject)         private             FFileName:   String;             FIsNewFile:Boolean;             FModified:   Boolean;             FFileFilter:String;             FDefaultExt:String;             FtlmObject:TtlmObject;             FOnCloseFile:   TCloseFileEvent;             FOnFileNameChanged:   TFileNameChangedEvent;             FOnNewFile:   TNewFileEvent;             FOnStartWizard:   TStartWizardEvent;             FOnOpenFile:   TOpenFileEvent;             FOnSaveFile:   TSaveFileEvent;         protected             procedure   SetModified(AValue:   Boolean);         public             constructor   Create;             destructor   Destroy;   override;             function   DoCloseFile:   Boolean;             function   DoNewFile:   Boolean;             function   DoStartWizard:Boolean;             function   DoOpenFile:   Boolean;overload;             function   DoOpenFile(const   AFileName:String):Boolean;overload;             function   DoSaveAsFile:   Boolean;             function   DoSaveFile:   Boolean;             property   FileName:   string   read   FFileName;             property   Modified:   Boolean   read   FModified   write   SetModified;             property   FileFilter:String   read   FFileFilter   write   FFileFilter;             property   DefaultExt:String   read   FDefaultExt   write   FDefaultExt;             property   OnCloseFile:   TCloseFileEvent   read   FOnCloseFile   write   FOnCloseFile;             property   OnFileNameChanged:   TFileNameChangedEvent   read   FOnFileNameChanged                             write   FOnFileNameChanged;             property   OnNewFile:   TNewFileEvent   read   FOnNewFile   write   FOnNewFile;             property   OnStartWizard:   TStartWizardEvent   read   FOnStartWizard   write   FOnStartWizard;             property   OnOpenFile:   TOpenFileEvent   read   FOnOpenFile   write   FOnOpenFile;             property   OnSaveFile:   TSaveFileEvent   read   FOnSaveFile   write   FOnSaveFile;         end;             implementation             {     *********************************   TFileManager   *********************************     }     constructor   TFileManager.Create;     begin         inherited   Create();         FtlmObject:=TtlmObject.Create(self);         FFileName:='';         FIsNewFile:=true;         Modified:=false;         if   Assigned(FOnFileNameChanged)   then   begin             FOnFileNameChanged(self,FFileName);         end;     end;         destructor   TFileManager.Destroy;     begin         if   Assigned(FtlmObject)   then   begin             FreeAndNil(FtlmObject);         end;         inherited   Destroy();     end;         function   TFileManager.DoCloseFile:   Boolean;     var         MsgResult:   TModalResult;         Succ:   Boolean;     begin         if   FModified   then   begin             Result:=false;             MsgResult:=MessageBox(Application.Handle,                     PChar(FtlmObject.Translate('FileModified','File   ''%s''   had   been   modified,   do   you   want   to   save   it?',[FFileName])),                     pchar(Application.Title),MB_ICONQUESTION   or   MB_YESNOCANCEL);             if   MsgResult=mrYES   then   begin                 if   not   DoSaveFile()   then                     exit;             end             else   if   MsgResult=mrCancel   then   begin                 exit;             end;             if   Assigned(FOnCloseFile)   then   begin                 Succ:=false;                 FOnCloseFile(self,Succ);                 Result:=Succ;                 if   Result   then   begin                     FFileName:='';                     FIsNewFile:=false;                     FModified:=false;                     if   Assigned(FOnFileNameChanged)   then   begin                         FOnFileNameChanged(self,FFileName);                     end;                 end;             end;         end         else   begin             if   Assigned(FOnCloseFile)   then   begin                 Succ:=false;                 FOnCloseFile(self,Succ);                 Result:=Succ;                 if   Result   then   begin                     FFileName:='';                     FIsNewFile:=false;                     FModified:=false;                     if   Assigned(FOnFileNameChanged)   then   begin                         FOnFileNameChanged(self,FFileName);                     end;                 end;             end;             Result:=true;         end;     end;        

    function   TFileManager.DoNewFile:   Boolean;     var         Succ:   Boolean;     begin         Result:=false;         if   not   DoCloseFile()   then             exit;         if   Assigned(FOnNewFile)   then   begin             Succ:=false;             FOnNewFile(self,Succ);             Result:=Succ;             if   Result   then   begin                 FFileName:=FtlmObject.Translate('NewAlbum','New   Album');                 FIsNewFile:=true;                 FModified:=false;                 if   Assigned(FOnFileNameChanged)   then   begin                     FOnFileNameChanged(self,FFileName);                 end;             end;         end;     end;         function   TFileManager.DoStartWizard:Boolean;     var         Succ:Boolean;         Info:TQuickWizardInfo;     begin         Result:=false;         if   Assigned(FOnStartWizard)   then   begin             Info.ImageList:=TStringList.Create();             Info.FileName:=FtlmObject.Translate('NewAlbum','New   Album');             Info.CopyImage:=false;             Info.CreateContent:=true;             try                 if   not   ShowQuickWizardForm(nil,Info)   then                     exit;                 if   not   DoCloseFile()   then                     exit;                 Succ:=false;                 FOnStartWizard(self,Info,Succ);                 Result:=Succ;                 if   Result   then   begin                     FFileName:=Info.FileName;                     FIsNewFile:=true;                     FModified:=true;                     if   Assigned(FOnFileNameChanged)   then   begin                         FOnFileNameChanged(self,FFileName   +   '   *');                     end;                 end                 else   begin                     DoNewFile();                 end;             finally                 Info.ImageList.Free;             end;         end;     end;         function   TFileManager.DoOpenFile:   Boolean;     var         Succ:   Boolean;         OpenDialog:   TOpenDialog;         FileNameTmp:   string;     begin         Result:=false;         if   Assigned(FOnOpenFile)   then   begin             OpenDialog:=TOpenDialog.Create(nil);             try                 OpenDialog.Filter:=FFileFilter;                 OpenDialog.FilterIndex:=0;                 OpenDialog.DefaultExt:=FDefaultExt;                 if   OpenDialog.Execute   then   begin                     FileNameTmp:=OpenDialog.FileName;                     if   (CompareText(FileNameTmp,FFileName)=0)   and   (not   FIsNewFile)   then   begin     //if   the   file   already   opened                         if   MessageBox(Application.Handle,PChar(FtlmObject.Translate('FileAlreadyOpened','This   file   already   opened,   do   you   want   to   open   it   anyway?')),                                 PChar(Application.Title),MB_ICONQUESTION+MB_YESNO)=mrNo   then   begin                             exit;                         end;                     end;                     if   not   DoCloseFile()   then                         exit;                     Succ:=false;                     FOnOpenFile(self,FileNameTmp,Succ);                     Result:=Succ;                     if   Result   then   begin                         FFileName:=FileNameTmp;                         FIsNewFile:=false;                         FModified:=false;                         if   Assigned(FOnFileNameChanged)   then   begin                             FOnFileNameChanged(self,FFileName);                         end;                     end                     else   begin                         DoNewFile();                     end;                 end;             finally                 OpenDialog.Free;             end;         end;     end;         function   TFileManager.DoOpenFile(const   AFileName:String):Boolean;     var         Succ:Boolean;     begin         Result:=false;         if   Assigned(FOnOpenFile)   then   begin             if   (CompareText(AFileName,FFileName)=0)   and   (not   FIsNewFile)   then   begin     //if   the   file   already   opened                 if   MessageBox(Application.Handle,PChar(FtlmObject.Translate('FileAlreadyOpened','This   file   already   opened,   do   you   want   to   open   it   anyway?')),                         PChar(Application.Title),MB_ICONQUESTION+MB_YESNO)=mrNo   then   begin                     exit;                 end;             end;             if   not   DoCloseFile()   then                 exit;             Succ:=false;             FOnOpenFile(self,AFileName,Succ);             Result:=Succ;             if   Result   then   begin                 FFileName:=AFileName;                 FIsNewFile:=false;                 FModified:=false;                 if   Assigned(FOnFileNameChanged)   then   begin                     FOnFileNameChanged(self,FFileName);                 end;             end             else   begin                 DoNewFile();             end;         end;     end;         function   TFileManager.DoSaveAsFile:   Boolean;     var         Succ:   Boolean;         SaveDialog:   TSaveDialog;         FileNameTmp:   string;     begin         Result:=false;         if   Assigned(FOnSaveFile)   then   begin             SaveDialog:=TSaveDialog.Create(nil);             try                 SaveDialog.Filter:=FFileFilter;                 SaveDialog.FilterIndex:=0;                 SaveDialog.DefaultExt:=FDefaultExt;                 SaveDialog.FileName:=FFileName;                 SaveDialog.Options:=SaveDialog.Options+[ofOverwritePrompt];                 if   SaveDialog.Execute   then   begin                     FileNameTmp:=SaveDialog.FileName;                     Succ:=false;                     FOnSaveFile(self,FileNameTmp,Succ);                     Result:=Succ;                     if   Result   then   begin                         FFileName:=FileNameTmp;                         FIsNewFile:=false;                         FModified:=false;                         if   Assigned(FOnFileNameChanged)   then   begin                             FOnFileNameChanged(self,FFileName);                         end;                     end;                 end;             finally                 SaveDialog.Free;             end;         end;     end;         function   TFileManager.DoSaveFile:   Boolean;     var         Succ:   Boolean;     begin         Result:=false;         if   (FileExists(FFileName))   and   (not   FIsNewFile)   then   begin             if   Assigned(FOnSaveFile)   then   begin                 Succ:=false;                 FOnSaveFile(self,FFileName,Succ);                 Result:=Succ;                 if   Result   then   begin                     FIsNewFile:=false;                     FModified:=false;                     if   Assigned(FOnFileNameChanged)   then   begin                         FOnFileNameChanged(self,FFileName);                     end;                 end;             end;         end         else   begin             Result:=DoSaveAsFile();         end;     end;         procedure   TFileManager.SetModified(AValue:   Boolean);     begin         if   FModified<>AValue   then   begin             if   Assigned(FOnFileNameChanged)   then   begin                 if   AValue   then   begin                     FOnFileNameChanged(self,FFileName+'   *');                 end                 else   begin                     FOnFileNameChanged(self,FFileName);                 end;             end;             FModified:=AValue;         end;     end;         end.    

     

    一段支持Splash启动窗体,以及在Splash窗体中显示启动的进度:     {-----------------------------------------------------------------------------       Unit   Name:   AppLdr       Author:         tony       Purpose:       Application   Loader       History:       2004.07.08   create     -----------------------------------------------------------------------------}         unit   AppLdr;         interface         uses         Windows,   Messages,   SysUtils,   Classes,   Controls,   Forms,   SplashForm,         TLMIniFilter,   ActiveX,   Common;         type         TAppLoader   =   class   (TObject)         private             FSplashForm:   TfrmSplash;             FtlmIniFilter:TtlmIniFilter;             procedure   OnAppLoading(ASender:TObject;AEvent:String;ADelay:Integer=50);         public             constructor   Create();             destructor   Destroy();override;             function   DoLoad:   Boolean;         end;         var         GAppLoader:TAppLoader;         implementation         uses         SkinMdl,   ConfigMgr,   CommMgr,   ICDeviceMgr,   HdgClient,   C1;         {     **********************************   TAppLoader   **********************************     }     constructor   TAppLoader.Create();     begin         inherited   Create();         FtlmIniFilter:=TtlmIniFilter.Create(Application);         FtlmIniFilter.LanguageFiles.Add('HDG2.chs');         FtlmIniFilter.LanguageExt:='.chs';         FtlmIniFilter.Active:=true;     end;         destructor   TAppLoader.Destroy();     begin         if   Assigned(frmC1)   then   begin             GCommManager.EndListen();             FreeAndNil(frmC1);         end;         if   Assigned(GHdgClient)   then   begin             FreeAndNil(GHdgClient);         end;         if   Assigned(GCommManager)   then   begin             FreeAndNil(GCommManager);         end;         if   Assigned(GICDevice)   then   begin             FreeAndNil(GICDevice);         end;         if   Assigned(GSkinModule)   then   begin             FreeAndNil(GSkinModule);         end;         if   Assigned(GConfigManager)   then   begin             FreeAndNil(GConfigManager);         end;         if   Assigned(FtlmIniFilter)   then   begin             FreeAndNil(FtlmIniFilter);         end;         inherited   Destroy();     end;         function   TAppLoader.DoLoad:   Boolean;     begin         Result:=false;         Application.Title:='HDG2';         FSplashForm:=TfrmSplash.Create(nil);         try             try                 FSplashForm.Show;                 OnAppLoading(nil,'Starting...');                 Sleep(200);                     GConfigManager:=TConfigManager.Create();                 GSkinModule:=TSkinModule.Create(nil);                     GICDevice:=TICDeviceDecorator.Create();                 GICDevice.OnAppLoading:=OnAppLoading;                 GICDevice.Initialize();                 GICDevice.OnAppLoading:=nil;                                 GCommManager:=TCommManagerDecorator.Create(nil);                 GCommManager.ConfigManager:=GConfigManager;                 GCommManager.ICDevice:=GICDevice;                 GCommManager.OnAppLoading:=OnAppLoading;                 GCommManager.Initialize(true,false,false);                 GCommManager.OnAppLoading:=nil;                     GHdgClient:=THdgClient.Create();                 GHdgClient.OnAppLoading:=OnAppLoading;                 GHdgClient.Initialize();                 GHdgClient.OnAppLoading:=nil;                                 OnAppLoading(nil,'Ending...');                     Screen.Cursors[crNo]:=LoadCursor(hInstance,'None');                 Application.CreateForm(TfrmC1,   frmC1);                                 GCommManager.BeginListen(frmC1);                 frmC1.SysCaption:=GConfigManager.SysCaption;     {$IFNDEF   HDGCLIENT}                 frmC1.SysLedCaption:=GConfigManager.SysLedCaption;     {$ENDIF}                     Result:=true;             except                 on   E:Exception   do   begin                     MessageBox(Application.Handle,PChar(E.ClassName+':'+#13+#10+E.Message),                             PChar(Application.Title),MB_ICONERROR);                 end;             end;         finally             FreeAndNil(FSplashForm);         end;     end;         procedure   TAppLoader.OnAppLoading(ASender:TObject;AEvent:String;                     ADelay:Integer);     begin         if   Assigned(FSplashForm)   then   begin             if   Assigned(ASender)   then   begin                 FSplashForm.lbl1.Caption:=ASender.ClassName+':   '+AEvent;             end             else   begin                 FSplashForm.lbl1.Caption:=AEvent;             end;             FSplashForm.Update;             if   ADelay>0   then                 Sleep(ADelay);         end;     end;         end.         工程的dpr中这样用:     begin         Application.Initialize;         GAppLoader:=TAppLoader.Create();         try             if   GAppLoader.DoLoad()   then   begin         Application.Run;             end;         finally             GAppLoader.Free;         end;     end.    

    获得Memo、RichEdit的光标位置:     --------------------------------------------------------------------------------         procedure   TForm1.Button1Click(Sender:   TObject);     var   Row,   Col   :   integer;     begin         Row   :=   SendMessage(Memo1.Handle,   EM_LINEFROMCHAR,   Memo1.SelStart,   0);         Col   :=   CustEdit.SelStart   -   SendMessage(Memo1.Handle,   EM_LINEINDEX,   -1,   0);         Edit1.Text:='行,列:'+IntToStr(Row)+','+IntToStr(Col);     end;

    Top

    一个可以为其父控件提供从浏览器拖入文件功能的类:         {-----------------------------------------------------------------------------       Unit   Name:   ImgDropper       Author:         tony       Purpose:       provide   the   function   for   drop   image   from   explorer.                             this   class   should   be   created   as   an   member   of   TPhotoPage.       History:       2004.01.31     create     -----------------------------------------------------------------------------}             unit   ImgDropper;         interface         uses         Windows,   Messages,   SysUtils,   Variants,   Classes,   Controls,   Graphics,         Forms,   ShellAPI,   TLMObject;         type         TImageDropper   =   class(TObject)         private             FParent:TWinControl;             FOldWindowProc:TWndMethod;             FtlmObject:TtlmObject;         protected             procedure   ParentWindowProc(var   Message:   TMessage);         public             constructor   Create(AParent:TWinControl);             destructor   Destroy();override;         end;         implementation         uses         AlbumMgr,   PhotoPge,   ImgDropFrm,   ImageLdr;         {   TImageDropper   }         procedure   TImageDropper.ParentWindowProc(var   Message:   TMessage);         procedure   EnumDropFiles(AFileList:TStringList);         var             pcFileName:PChar;             i,iSize,iFileCount:Integer;         begin             try                 pcFileName:='';                 iFileCount:=DragQueryFile(Message.WParam,$FFFFFFFF,pcFileName,MAX_PATH);                 for   I:=0   to   iFileCount-1   do   begin                     iSize:=DragQueryFile(Message.WParam,i,nil,0)+1;                     pcFileName:=StrAlloc(iSize);                     DragQueryFile(Message.WParam,i,pcFileName,iSize);                     AFileList.Add(pcFileName);                     StrDispose(pcFileName);                 end;             finally                 DragFinish(Message.WParam);             end;         end;     var         FileList:TStringList;         RdPage:TRdPage;         DropInfo:TImgDropInfo;         I:Integer;         NewRdPage:TRdPage;         ImageLoader:TImageLoader;         Bmp:TBitmap;     begin         if   Message.Msg=WM_DROPFILES   then   begin             FileList:=TStringList.Create();             try                 if   not   (FParent   is   TPhotoPage)   then                     exit;                 RdPage:=TPhotoPage(FParent).RdPage;                 if   not   Assigned(RdPage)   then                     exit;                 EnumDropFiles(FileList);                 if   FileList.Count=1   then   begin                 //only   dropped   one   image                     RdPage.DoAddImageItem(FileList.Strings[0]);                 end                 else   begin                                                       //dropped   several   images                     DropInfo.PlaceEachPage:=true;                     if   not   ShowImgDropForm(nil,DropInfo)   then   begin                         exit;                     end;                     if   DropInfo.PlaceEachPage   then   begin                         ImageLoader:=TImageLoader.Create();                         Bmp:=TBitmap.Create();                         try                             for   I:=0   to   FileList.Count-1   do   begin                                 NewRdPage:=RdPage.Parent.DoInsertPage(RdPage.PageIndex+1);                                 if   not   Assigned(NewRdPage)   then   begin                                     break;                                 end;                                 ImageLoader.LoadFromFile(FileList.Strings[I],Bmp);                                 NewRdPage.DoAddImageItem(FileList.Strings[I],Bmp.Width,Bmp.Height);                             end;                         finally                             ImageLoader.Free;                             Bmp.Free;                         end;                     end                     else   begin                         for   I:=0   to   FileList.Count-1   do   begin                             RdPage.DoAddImageItem(FileList.Strings[I]);                         end;                     end;                     MessageBox(FParent.Handle,PChar(FtlmObject.Translate('ImagesAdded','%d   images   had   been   added!',[FileList.Count])),PChar(Application.Title),MB_ICONINFORMATION);                 end;             finally                 FileList.Free;             end;         end         else   begin             FOldWindowProc(Message);         end;     end;         constructor   TImageDropper.Create(AParent:TWinControl);     begin         inherited   Create();         FParent:=AParent;         DragAcceptFiles(FParent.Handle,true);         FOldWindowProc:=FParent.WindowProc;         FParent.WindowProc:=ParentWindowProc;         FtlmObject:=TtlmObject.Create(self);     end;         destructor   TImageDropper.Destroy();     begin         if   Assigned(FtlmObject)   then   begin             FreeAndNil(FtlmObject);         end;         DragAcceptFiles(FParent.Handle,false);         FParent.WindowProc:=FOldWindowProc;         inherited   Destroy();     end;         end.    

    获得Memo、RichEdit的光标位置:     --------------------------------------------------------------------------------         procedure   TForm1.Button1Click(Sender:   TObject);     var   Row,   Col   :   integer;     begin         Row   :=   SendMessage(Memo1.Handle,   EM_LINEFROMCHAR,   Memo1.SelStart,   0);         Col   :=   CustEdit.SelStart   -   SendMessage(Memo1.Handle,   EM_LINEINDEX,   -1,   0);         Edit1.Text:='行,列:'+IntToStr(Row)+','+IntToStr(Col);     end;

    Top16楼  GreatSuperYoyoNC   (ExSystem|麻烦结帖[-_-])   回复于 2004-07-20 16:11:30  得分 0

    //--[Yoyoworks]----------------------------------------------------------------       //工程名称:prjPowerFlashPlayer       //软件名称:iPowerFlashPlayer       //单元作者:许子健       //开始日期:2004年03月14日,14:31:16       //单元功能:用于音量调整的类。       //-----------------------------------------------------------[SHANGHAi|CHiNA]--                   Unit   untTVolume;           Interface           Uses           MMSystem,   SysUtils;           Type           TVolume   =   Class(TObject)           Private               FVolume:   LongInt;   //存储音量。               FIsMute:   Boolean;   //存储静音值。               Procedure   SetLeftVolume(Volume:   Integer);   //设置左声道的音量。               Function   GetLeftVolume:   Integer;   //获得左声道的音量。               Procedure   SetRightVolume(Volume:   Integer);   //设置右声道的音量。               Function   GetRightVolume:   Integer;   //获得右声道的音量。               Procedure   SetIsMute(IsMute:   Boolean);   //设置是否静音。           Public               Constructor   Create;               Destructor   Destroy;   Override;           Published               Property   LeftVolume:   Integer   Read   GetLeftVolume   Write   SetLeftVolume;               Property   RightVolume:   Integer   Read   GetRightVolume   Write   SetRightVolume;               Property   Mute:   Boolean   Read   FIsMute   Write   SetIsMute;           End;           Implementation           //   -----------------------------------------------------------------------------       //   过程名:       TVolume.Create       //   参数:           无       //   返回值:       无       //   -----------------------------------------------------------------------------           Constructor   TVolume.Create;       Begin           Inherited   Create;           FVolume   :=   0;           FIsMute   :=   False;           //初始化变量           waveOutGetVolume(0,   @FVolume);   //得到现在音量       End;           //   -----------------------------------------------------------------------------       //   过程名:       TVolume.Destroy       //   参数:           无       //   返回值:       无       //   -----------------------------------------------------------------------------           Destructor   TVolume.Destroy;       Begin           Inherited   Destroy;       End;           //   -----------------------------------------------------------------------------       //   过程名:       TVolume.SetLeftVolume       //   参数:           Volume:   Integer       //   返回值:       无       //   -----------------------------------------------------------------------------           Procedure   TVolume.SetLeftVolume(Volume:   Integer);       Begin           If   (Volume   <   0)   Or   (Volume   >   255)   Then               Raise   Exception.Create('Range   error   of   the   left   channel   [0   to   255].');           //如果“Volume”参数不在0至255的范围里,则抛出异常。               If   FIsMute   =   False   Then               Begin                   waveOutGetVolume(0,   @FVolume);                   //@示指向变量Volume的指针(32位),调用此函数的用意就是得到右声道的值,做到在调节左声道的时候,不改变右声道。                   FVolume   :=   FVolume   And   $FFFF0000   Or   (Volume   Shl   8);   //数字前加$表示是十六进制                   waveOutSetVolume(0,   FVolume);               End                   //如果不是静音状态,则改变音量;           Else               FVolume   :=   FVolume   And   $FFFF0000   Or   (Volume   Shl   8);           //否则,只改变变量。           End;           //   -----------------------------------------------------------------------------       //   过程名:       TVolume.SetRightVolume       //   参数:           Volume:   Integer       //   返回值:       无       //   -----------------------------------------------------------------------------           Procedure   TVolume.SetRightVolume(Volume:   Integer);       Begin           If   (Volume   <   0)   Or   (Volume   >   255)   Then               Raise   Exception.Create('Range   error   of   the   right   channel   [0   to   255].');               If   FIsMute   =   False   Then               Begin                   waveOutGetVolume(0,   @FVolume);                   FVolume   :=   FVolume   And   $0000FFFF   Or   (Volume   Shl   24);                   waveOutSetVolume(0,   FVolume);               End           Else               FVolume   :=   FVolume   And   $0000FFFF   Or   (Volume   Shl   24);       End;           //   -----------------------------------------------------------------------------       //   过程名:       TVolume.SetIsMute       //   参数:           IsMute:   Boolean       //   返回值:       无       //   -----------------------------------------------------------------------------           Procedure   TVolume.SetIsMute(IsMute:   Boolean);       Begin           FIsMute   :=   IsMute;           If   FIsMute   =   True   Then               waveOutSetVolume(0,   0)           Else               waveOutSetVolume(0,   FVolume);       End;           //   -----------------------------------------------------------------------------       //   函数名:       TVolume.GetLeftVolume       //   参数:           无       //   返回值:       Integer       //   -----------------------------------------------------------------------------           Function   TVolume.GetLeftVolume:   Integer;       Begin           If   FIsMute   =   False   Then               waveOutGetVolume(0,   @FVolume);   //得到现在音量           Result   :=   Hi(FVolume);   //转换成数字           End;           //   -----------------------------------------------------------------------------       //   函数名:       TVolume.GetRightVolume       //   参数:           无       //   返回值:       Integer       //   -----------------------------------------------------------------------------           Function   TVolume.GetRightVolume:   Integer;       Begin           If   FIsMute   =   False   Then               waveOutGetVolume(0,   @FVolume);   //得到现在音量           Result   :=   Hi(FVolume   Shr   16);   //转换成数字       End;           End.

     

    点击DBGrid的Title对查询结果排序   关键词:DBGrid   排序                   欲实现点击DBGrid的Title对查询结果排序,想作一个通用程序,不是一事一议,例如不能在SQL语句中增加Order   by   ...,因为SQL可能原来已经包含Order   by   ...,而且点击另一个Title时又要另外排序,目的是想作到象资源管理器那样随心所欲。         procedure   TFHkdata.SortQuery(Column:TColumn);     var     SqlStr,myFieldName,TempStr:   string;     OrderPos:   integer;     SavedParams:   TParams;     begin     if   not   (Column.Field.FieldKind   in   [fkData,fkLookup])   then   exit;     if   Column.Field.FieldKind   =fkData   then           myFieldName   :=   UpperCase(Column.Field.FieldName)     else           myFieldName   :=   UpperCase(Column.Field.KeyFields);     while   Pos(myFieldName,';')<>0   do     myFieldName   :=   copy(myFieldName,1,Pos(myFieldName,';')-1)+   ','   +   copy(myFieldName,Pos(myFieldName,';')+1,100);     with   TQuery(TDBGrid(Column.Grid).DataSource.DataSet)   do     begin           SqlStr   :=   UpperCase(Sql.Text);           //   if   pos(myFieldName,SqlStr)=0   then   exit;           if   ParamCount>0   then           begin               SavedParams   :=   TParams.Create;               SavedParams.Assign(Params);           end;           OrderPos   :=   pos('ORDER',SqlStr);           if   (OrderPos=0)   or   (pos(myFieldName,copy(SqlStr,OrderPos,100))=0)   then               TempStr   :=   '   Order   By   '   +   myFieldName   +   '   Asc'           else   if   pos('ASC',SqlStr)=0   then               TempStr   :=   '   Order   By   '   +   myFieldName   +   '   Asc'           else               TempStr   :=   '   Order   By   '   +   myFieldName   +   '   Desc';           if   OrderPos<>0   then   SqlStr   :=   Copy(SqlStr,1,OrderPos-1);           SqlStr   :=   SqlStr   +   TempStr;           Active   :=   False;           Sql.Clear;           Sql.Text   :=   SqlStr;           if   ParamCount>0   then           begin               Params.AssignValues(SavedParams);               SavedParams.Free;           end;           Prepare;           Open;     end;     end;                   去掉DbGrid的自动添加功能                         移动到最后一条记录时再按一下“下”就会追加一条记录,如果去掉这项功能             procedure   TForm1.DataSource1Change(Sender:   TObject;   Field:   TField);           begin               if   TDataSource(Sender).DataSet.Eof   then   TDataSource(Sender).DataSet.Cancel;           end;                     DBGrid不支持鼠标的上下移动的解决代码自己捕捉WM_MOUSEWHEEL消息处理     private     OldGridWnd   :   TWndMethod;     procedure   NewGridWnd   (var   Message   :   TMessage);     public         procedure   TForm1.NewGridWnd(var   Message:   TMessage);     var     IsNeg   :   Boolean;     begin     if   Message.Msg   =   WM_MOUSEWHEEL   then     begin           IsNeg   :=   Short(Message.WParamHi)   <   0;           if   IsNeg   then               DBGrid1.DataSource.DataSet.MoveBy(1)           else               DBGrid1.DataSource.DataSet.MoveBy(-1)     end     else           OldGridWnd(Message);     end;         procedure   TForm1.FormCreate(Sender:   TObject);     begin     OldGridWnd   :=   DBGrid1.WindowProc   ;     DBGrid1.WindowProc   :=   NewGridWnd;     end;                           dbgrid中移动焦点到指定的行和列       dbgrid是从TCustomGrid继承下来的,它有col与row属性,只不过是protected的,不能直接访问,要处理一下,可以这样:               TDrawGrid(dbgrid1).row:=row;           TDrawGrid(dbgrid1).col:=col;           dbgrid1.setfocus;     就可以看到效果了。               1   这个方法是绝对有问题的,它会引起DBGrid内部的混乱,因为DBGrid无法定位当前纪录,如果DBGrid只读也就罢了(只读还是会出向一些问题,比如原本只能单选的纪录现在可以出现多选等等,你可以自己去试试),如果DBGrid可编辑那问题就可大了,因为当前纪录的关系,你更改的数据字段很可能不是你想象中的           2   我常用的解决办法是将上程序改为(随便设置col是安全的,没有一点问题)               Query1.first;           TDrawGrid(dbgrid1).col:=1;           dbgrid1.setfocus;               这就让焦点移到第一行第一列当中                   如何使DBGRID网格的颜色随此格中的数据值的变化而变化?       在做界面的时候,有时候为了突出显示数据的各个特性(如过大或者过小等),需要通过改变字体或者颜色,本文就是针对这个情况进行的说明。               如何使DBGRID网格的颜色随此格中的数据值的变化而变化。如<60的网格为红色?           Delphi中数据控制构件DBGrid是用来反映数据表的最重要、也是最常用的构件。在应用程序中,如果以彩色的方式来显示DBGrid,将会增加其可视性,尤其在显示一些重要的或者是需要警示的数据时,可以改变这些数据所在的行或列的前景和背景的颜色。       DBGrid属性DefaultDrawing是用来控制Cell(网格)的绘制。若DefaultDrawing的缺省设置为True,意思是Delphi使用DBGrid的缺省绘制方法来制作网格和其中所包含的数据,数据是按与特定列相连接的Tfield构件的DisplayFormat或EditFormat特性来绘制的;若将DBGrid的DefaultDrawing特性设置成False,Delphi就不绘制网格或其内容,必须自行在TDBGrid的OnDrawDataCell事件中提供自己的绘制例程(自画功能)。       在这里将用到DBGrid的一个重要属性:画布Canvas,很多构件都有这一属性。Canvas代表了当前被显示DBGrid的表面,你如果把另行定义的显示内容和风格指定给DBGrid对象的Canvas,DBGrid对象会把Canvas属性值在屏幕上显示出来。具体应用时,涉及到Canvas的Brush属性和FillRect方法及TextOut方法。Brush属性规定了DBGrid.Canvas显示的图像、颜色、风格以及访问Windows   GDI   对象句柄,FillRect方法使用当前Brush属性填充矩形区域,方法TextOut输出Canvas的文本内容。           以下用一个例子来详细地说明如何显示彩色的DBGrid。在例子中首先要有一个DBGrid构件,其次有一个用来产生彩色筛选条件的SpinEdit构件,另外还有ColorGrid构件供自由选择数据单元的前景和背景的颜色。           1.建立名为ColorDBGrid的Project,在其窗体Form1中依次放入所需构件,并设置属性为相应值,具体如下所列:              Table1   DatabaseName:   DBDEMOS             TableName:   EMPLOYEE.DB             Active:   True;       DataSource1   DataSet:   Table1       DBGrid1   DataSource1:   DataSource1             DefaultDrawing:   False       SpinEdit1   Increment:200             Value:   20000       ColorGrid1   GridOrdering:   go16*1           2.为DBGrid1构件OnDrawDataCell事件编写响应程序:         //这里编写的程序是<60的网格为红色的情况,其他的可以照此类推       procedure   TForm1.DBGrid1DrawDataCell(Sender:   TObject;   const   Rect:   TRect;Field:   TField;   State:   TGridDrawState);       begin          if   Table1.Fieldbyname(′Salary′).value<=SpinEdit1.value   then          DBGrid1.Canvas.Brush.Color:=ColorGrid1.ForeGroundColor          else               DBGrid1.Canvas.Brush.Color:=ColorGrid1.BackGroundColor;          DBGrid1.Canvas.FillRect(Rect);          DBGrid1.Canvas.TextOut(Rect.left+2,Rect.top+2,Field.AsString);       end;           这个过程的作用是当SpinEdit1给定的条件得以满足时,如′salary′变量低于或等于SpinEdit1.Value时,DBGrid1记录以ColorGrid1的前景颜色来显示,否则以ColorGrid1的背景颜色来显示。然后调用DBGrid的Canvas的填充过程FillRect和文本输出过程重新绘制DBGrid的画面。           3.为SpinEdit1构件的OnChange事件编写响应代码:           procedure   TForm1.SpinEdit1Change(Sender:   TObject);       begin          DBGrid1.refresh;     //刷新是必须的,一定要刷新哦       end;           当SpinEdit1构件的值有所改变时,重新刷新DBGrid1。           4.为ColorGrid1的OnChange事件编写响应代码:           procedure   TForm1.ColorGrid1Change(Sender:   TObject);       begin          DBGrid1.refresh;         //刷新是必须的,一定要刷新哦           end;           当ColorGrid1的值有所改变时,即鼠标的右键或左键单击ColorGrid1重新刷新DBGrid1。           5.为Form1窗体(主窗体)的OnCreate事件编写响应代码:           procedure   TForm1.FormCreate(Sender:   TObject);       begin          ColorGrid1.ForeGroundIndex:=9;             ColorGrid1.BackGroundIndex:=15;      end;           在主窗创建时,将ColorGrid1的初值设定前景为灰色,背景为白色,也即DBGrid的字体颜色为灰色,背景颜色为白色。           6.现在,可以对ColorDBGrid程序进行编译和运行了。当用鼠标的左键或右键单击ColorGrid1时,DBGrid的字体和背景颜色将随之变化。           在本文中,只是简单展示了以彩色方式显示DBGrid的原理,当然,还可以增加程序的复杂性,使其实用化。同样道理,也可以将这个方法扩展到其他拥有Canvas属性的构件中,让应用程序的用户界面更加友好。                           判断Grid是否有滚动条?这是一个小技巧,如果为了风格的统一的话,还是不要用了。:)         。。。         if   (GetWindowlong(Stringgrid1.Handle,   GWL_STYLE)   and   WS_VSCROLL)   <>   0   then           ShowMessage('Vertical   scrollbar   is   visible!');     if   (GetWindowlong(Stringgrid1.Handle,   GWL_STYLE)   and   WS_HSCROLL)   <>   0   then           ShowMessage('Horizontal   scrollbar   is   visible!');         。。。          

    {=================================================================         功     能:     返回网络中SQLServer列表         参     数:         List:     需要填充的List         返回值:     成功:     True,并填充List     失败     False         =================================================================}         Function     GetSQLServerList(var     List:     Tstringlist):     boolean;         var           i:     integer;           SQLServer:     Variant;           ServerList:     Variant;         begin               Result     :=     False;               List.Clear;               try                   SQLServer     :=     CreateOleObject('SQLDMO.Application');                   ServerList     :=     SQLServer.ListAvailableSQLServers;                   for     i     :=     1     to     Serverlist.Count     do                           list.Add     (Serverlist.item(i));                   Result     :=     True;               Finally                   SQLServer     :=null;                   ServerList     :=null;               end;         end;        

                            如何获取局域网中的所有   SQL   Server   服务器         文献参考来源:Delphi   深度探索         我一直想在我的应用程序中获得关于   SQL   Server   更详细的信息。直到最近利用   SQLDMO(SQL   Distributed   Management   Objects)   才得以实现这个想法。SQLDMO   提供了非常强大的功能,我们几乎可以利用程序实现任何   SQL   Server   拥有的功能。在这篇文章中我将向您展示如何得到局域网中所有   SQL   Servers   服务器、如何连接、如何获得服务器中的所有数据库。         SQLDMO   对像来自   SQL   Server   2000   提供的动态连接库   SQLDMO.dll。     这个   dll   本身是一个   COM   对像,首先你必须从类型库中引用Microsoft   SQLDMO   Object   Library   (Version   8.0).   Delphi   会自动为你生成SQLDMO_TLB.PAS文件,文件中包括了所有   COM   对象的接口。                         在这里我们需要注意,由于引入的SQLDMO   “TDatabase”和   “TApplication”和其它几个缺省类名与   Delphi   自带的类名冲突,所以自己可以修改成   _TypeName   的形式。或者其它的名字,我在这里改成   T_Application   、T_Database   等。         我们下一步要做的是在我们的程序中引入单元文件   SQLDMO_TLB.PAS   。   应用程序单元名称是   SqlServers           程序运行界面如下:                       服务器列表中是局域网中所有的   SQL   SERVER   服务器,选择服务器后输入用户名和密码,下拉数据库列表,程序会列出此服务器中的所有数据库.         程序源代码如下:         unit   SqlServers;         interface         uses             Windows,   Messages,   SysUtils,   Classes,   Graphics,   Controls,   Forms,   Dialogs,             StdCtrls,   Buttons,   ComCtrls   ,   SQLDMO_TLB;//注意别忘了引入此文件         type             TdmoObject   =   record                 SQL_DMO         :   _SQLServer;                 lConnected   :   boolean;             end;                   type             TFormServersList   =   class(TForm)                 Label1:   TLabel;                 Label2:   TLabel;                 CB_ServerNames:   TComboBox;                 CB_DataNames:   TComboBox;                 Label3:   TLabel;                 Label4:   TLabel;                 Ed_Login:   TEdit;                 Ed_Pwd:   TEdit;                 BitBtn1:   TBitBtn;                 BitBtn2:   TBitBtn;                 procedure   FormCreate(Sender:   TObject);                 procedure   FormCloseQuery(Sender:   TObject;   var   CanClose:   Boolean);                 procedure   FormClose(Sender:   TObject;   var   Action:   TCloseAction);                 procedure   FormShow(Sender:   TObject);                 procedure   BitBtn2Click(Sender:   TObject);                 procedure   CB_DataNamesDropDown(Sender:   TObject);             private                 server_Names   :   TStringList;                 //对象集合                       PdmoObject   :   array   of   TdmoObject;                 //获取所有的远程服务器                 Function   GetAllServers(ServerList   :   TStringList)   :   Boolean;                 {   Private   declarations   }             public                 {   Public   declarations   }             end;                   var             FormServersList:   TFormServersList;         implementation                   {$R   *.DFM}                   {   TForm1   }                   Function   TFormServersList.GetAllServers(ServerList   :   TStringList)   :   Boolean;         var             sApp   :   _Application   ;             sName   :   NameList;             iPos   :   integer;         begin             Result   :=   True   ;             try                 sApp   :=   CoApplication_.Create   ;   //创建的对象不用释放,delphi   自己会释放                 sName   :=   sApp.ListAvailableSQLServers;             except                 Result   :=   False;                 Exit;             end;             if   sName.Count   >   0   then   //   之所以 iPos   从1开始,是因为0   位置为空值即   '   '             for   iPos   :=   1   to   sName.Count   -   1   do             begin                 CB_ServerNames.Items.Add(sName.Item(iPos));                 ServerList.Add(sName.Item(iPos));             end;         end;                   procedure   TFormServersList.FormCreate(Sender:   TObject);         var             lcv   :   integer;         begin             server_Names   :=   TStringList.Create;             if   not   GetAllServers(server_Names)   then             begin                 Application.MessageBox('无法获取服务器列表,可能缺少客户端DLL库函数','错误提示',MB_OK);                 exit;             end;             for   lcv   :=   0   to   server_Names.Count   -   1   do             begin                 SetLength(PdmoObject,lcv   +   1);                 with   PdmoObject[lcv]   do                 begin                     SQL_DMO   :=   CoSQLServer.Create;                     SQL_DMO.Name   :=   Trim(server_Names[lcv]);                     //登陆安全属性,NT   身份验证                     SQL_DMO.LoginSecure   :=   false;                     //   设置一个连接超时                     SQL_DMO.LoginTimeout   :=   3;                     //自动重新登陆,如果第一次失败后                     SQL_DMO.AutoReconnect   :=   true;                     SQL_DMO.ApplicationName   :=   server_Names[lcv];                     lConnected   :=   false;                 end;             end;         end;                   procedure   TFormServersList.FormCloseQuery(Sender:   TObject;   var   CanClose:   Boolean);         begin             server_Names.Free;         end;                   procedure   TFormServersList.FormClose(Sender:   TObject;   var   Action:   TCloseAction);         begin             Action   :=   CaFree;         end;                   procedure   TFormServersList.FormShow(Sender:   TObject);         begin             if   CB_ServerNames.Items.Count   >   0   then   //列举所有服务器名字                 CB_ServerNames.Text   :=   CB_ServerNames.Items.Strings[0];         end;                   procedure   TFormServersList.BitBtn2Click(Sender:   TObject);         begin             Close   ;         end;                   procedure   TFormServersList.CB_DataNamesDropDown(Sender:   TObject);         var             icount   ,Server_B   :   integer;         begin             CB_DataNames.Clear;             Screen.Cursor   :=   CrHourGlass;             Server_B   :=   CB_ServerNames.Items.IndexOf(CB_ServerNames.Text)   ;             with   PdmoObject[Server_B].SQL_DMO   do             begin                 if   not   PdmoObject[Server_B].lConnected   then                 try                     Connect(Name,Trim(Ed_Login.Text),Trim(Ed_Pwd.Text));                 except                     Screen.Cursor   :=   CrDefault   ;                     Application.MessageBox('请检查用户名或密码是否正确','连接失败',MB_OK);                     Exit   ;                 end;                 if   not   VerifyConnection(SQLDMOConn_ReconnectIfDead)   then                 begin                     ShowMessage('在试图连接到SQL   SERVER   2000   时出现错误'   +   #10#13   +                                                                   '确信是否加在了动态连接库SQLDMO.DLL');                     exit;                 end   else                     PdmoObject[Server_B].lConnected   :=   True   ;                 Databases.Refresh(true);                 for   icount   :=   1   to   Databases.Count   do                     CB_DataNames.Items.Add(Databases.Item(icount,null).name);             end;             Screen.Cursor   :=   CrDefault   ;         end         end.    

    一个使用了OpenGL的3D空间浏览程序。     unit   Unit1;         interface         uses         Windows,   Messages,   SysUtils,   Classes,   Graphics,   Controls,   Forms,   Dialogs,OpenGL,         ExtCtrls,   StdCtrls,   Buttons,math;         type         TGLPoint3D=packed   array[0..2]   of   GLFloat;         TPoint3D=record               x,y,z:Integer;               color:Integer;               end;         TLineClash=record                   TestLines:array[0..1]   of   Integer;                   MaxX,MinX:GLFloat;                   TestK,TestS:GLFloat;                   end;         TPGLPoint3D=^TGLPoint3D;         T3DObject=packed   record               ID:Integer;               x,y,z,Orientx,Orienty,Orientz:Real;               PointsNum:Integer;               ClashsNum:Integer;               Clashs:array   of   TLineClash;               Points:array   of   TGLPoint3D;         end;         TP3DObject=^T3DObject;         TPerson=record               orientx,orienty,orientz:Real;               oldp,newp:TGLPoint3D;         end;         TForm1   =   class(TForm)             Timer1:   TTimer;             Panel1:   TPanel;             procedure   FormCreate(Sender:   TObject);             procedure   FormClose(Sender:   TObject;   var   Action:   TCloseAction);             procedure   Panel1MouseDown(Sender:   TObject;   Button:   TMouseButton;                 Shift:   TShiftState;   X,   Y:   Integer);             procedure   FormKeyDown(Sender:   TObject;   var   Key:   Word;                 Shift:   TShiftState);             procedure   Panel1Resize(Sender:   TObject);             procedure   Timer1Timer(Sender:   TObject);         private             {   Private   declarations   }         public             {   Public   declarations   }             DC:HDC;             hglrc:HGLRC;             mdx,mdy:Integer;             numofpoints:Integer;             points:array[0..$ffff]   of   TPoint3D;             person:TPerson;             objs:array[0..100]   of   T3DObject;             procedure   InitOpenGL;             procedure   UninitOpenGL;             procedure   DrawPic;             procedure   DrawPic2;             procedure   DrawObject(pObj:TP3DObject);             procedure   InitObjects;             function   TestClash(pObj:TP3DObject;var   p1,p2:TGLPoint3D):Boolean;         end;         const   MaxWidth=300.0;MaxHeight=300.0;MaxDepth=300.0;                 LeftKey=37;                 UpKey=37;                 RightKey=37;                 DownKey=37;                 ps:packed   array[0..3]   of   TGLPoint3D=((0.0,0.0,0.0),(0.0,1.0,0.0),(-5.0,0.0,0.0),(-5.0,1.0,0.0));     var         Form1:   TForm1;             implementation         {$R   *.DFM}         procedure   TForm1.InitOpenGL;     var               pfd:PIXELFORMATDESCRIPTOR;               pf:Integer;     begin               with   pfd   do               begin                         nSize:=sizeof(PIXELFORMATDESCRIPTOR);                         nVersion:=1;                         dwFlags:= PFD_DRAW_TO_WINDOW   or   PFD_SUPPORT_OPENGL     or   PFD_DOUBLEBUFFER;                         iPixelType:=   PFD_TYPE_RGBA;                         cColorBits:=   24;                         cRedBits:=   0;                         cRedShift:=   0;                         cGreenBits:=   0;                         cGreenShift:=   0;                         cBlueBits:=   0;                         cBlueShift:=   0;                         cAlphaBits:=   0;                         cAlphaShift:=   0;                         cAccumBits:=0;                         cAccumRedBits:=   0;                         cAccumGreenBits:=   0;                         cAccumBlueBits:=   0;                         cAccumAlphaBits:=   0;                         cDepthBits:=   32;                         cStencilBits:=   0;                         cAuxBuffers:=   0;                         iLayerType:=   PFD_MAIN_PLANE;                         bReserved:=   0;                         dwLayerMask:=   0;                         dwVisibleMask:=   0;                         dwDamageMask:=   0;         end;               DC:=GetWindowDC(Panel1.Handle);     pf:=ChoosePixelFormat(DC,@pfd);     SetPixelFormat(DC,pf,@pfd);     hglrc:=wglCreateContext(DC);               wglMakeCurrent(DC,hglrc);               glMatrixMode(GL_PROJECTION);               glLoadIdentity;               glEnable(GL_DEPTH_TEST);     end;         procedure   TForm1.UninitOpenGL;     begin     if   hglrc<>0   then   wglDeleteContext(hglrc);         end;         procedure   TForm1.FormCreate(Sender:   TObject);     begin               person.orientx   :=0;               person.orienty   :=0;               person.orientz   :=0;               person.newp[0]:=0.0;               person.newp[1]:=1.2;               person.newp[2]:=-5.0;               person.oldp[0]:=0.0;               person.oldp[1]:=1.2;               person.oldp[2]:=0.0;               InitObjects;               InitOpenGL;     end;         procedure   TForm1.FormClose(Sender:   TObject;   var   Action:   TCloseAction);     begin               UninitOpenGL;     end;             procedure   TForm1.DrawPic;     var               i:Integer;     begin               glClear(GL_COLOR_BUFFER_BIT);               glBegin(GL_POINTS);               for   i:=0   to   numofpoints-1   do               begin                         glColor3ubv(@(points[i].color));                         glVertex3d(points[i].x/MaxWidth,points[i].y/MaxHeight,points[i].z/MaxDepth);               end;               glEnd;               glEnable(GL_DEPTH_TEST);               glClear(GL_DEPTH_BUFFER_BIT);               glFlush;               SwapBuffers(DC);     end;        

    procedure   TForm1.Panel1MouseDown(Sender:   TObject;   Button:   TMouseButton;         Shift:   TShiftState;   X,   Y:   Integer);     begin               mdx:=X;               mdy:=Y;     end;             procedure   TForm1.DrawPic2;     const   MaxX=90.0;                 MinX=-90.0;                 MaxZ=90.0;                 MinZ=-90.0;                 StepX=(MaxX-MinX)/100;                 StepZ=(MaxZ-MinZ)/100;     var               i:Real;               gp:GLUquadricObj;               j:Integer;     begin               glClearColor(0.0,0.0,0.0,0.0);               glClear(GL_COLOR_BUFFER_BIT);               glColor3f(1.0,1.0,0.0);               glPushMatrix;               gp:=gluNewQuadric;               gluQuadricDrawStyle(gp,GLU_LINE);               glTranslatef(0.0,1.0,0.0);               gluSphere(gp,0.8,20,20);               glTranslatef(10.0,0.0,0.0);               gluCylinder(gp,1.0,0.6,1.2,20,10);               gluDeleteQuadric(gp);               glPopMatrix;               glColor3f(1.0,1.0,1.0);               glBegin(GL_LINES);               i:=MinX;               while   i<MaxX   do               begin                         glVertex3d(i,0,MinZ);                         glVertex3d(i,0,MaxZ);                         i:=i+StepX;               end;               i:=MinZ;               while   i<MaxZ   do               begin                         glVertex3d(MinX,0,i);                         glVertex3d(MaxX,0,i);                         i:=i+StepZ;               end;               glEnd;               glBegin(GL_QUAD_STRIP);               for   j:=0   to   3   do               begin                         glVertex3f(ps[j,0],ps[j,1],ps[j,2]);               end;               glEnd;               DrawObject(@objs[0]);               SwapBuffers(DC);     end;         procedure   TForm1.FormKeyDown(Sender:   TObject;   var   Key:   Word;         Shift:   TShiftState);     const               StepA=0.8;     var               ca,cr:Real;               thenewp:TGLPoint3D;     begin               ca:=0;               cr:=0;               case   Key   of                         38:                                   cr:=0.1;                         40:                                   cr:=-0.1;                         37:                                   ca:=-StepA;                         39:                                   ca:=StepA;                         13:                 end;                 person.orienty:=person.orienty+ca;                 person.oldp[0]:=person.newp[0];                 person.oldp[2]:=person.newp[2];                 thenewp[0]:=   person.newp[0]+cr*sin(DegToRad(person.orienty));                 thenewp[2]:=   person.newp[2]+cr*cos(DegToRad(person.orienty));                 if   thenewp[0]>80   then   thenewp[0]:=80;                 if   thenewp[2]>80   then   thenewp[2]:=80;                 if   thenewp[0]<-80   then   thenewp[0]:=-80;                 if   thenewp[2]<-80   then   thenewp[2]:=-80;     //             if   not   TestClash(@objs[0],person.oldp,thenewp)   then                 begin                           person.newp[0]:=thenewp[0];                           person.newp[2]:=thenewp[2];                           wglMakeCurrent(DC,hglrc);                           glMatrixMode(GL_PROJECTION);                           glLoadIdentity;                           gluPerspective(45.0,1.0,0.01,40.0);                           glRotatef(person.orientz,0.0,0.0,1.0);                           glRotatef(person.orientx,1.0,0.0,0);                           glRotatef(person.orienty,0.0,1.0,0);                           glTranslatef(-person.newp[0],-person.newp[1],person.newp[2]);                           glClear(GL_DEPTH_BUFFER_BIT);                           DrawPic2;                 end;     end;         procedure   TForm1.Panel1Resize(Sender:   TObject);     var               a:Word;     begin               a:=13;               glViewPort(0,0,Panel1.Width,Panel1.Height);               FormKeyDown(Sender,a,[]);     end;         procedure   TForm1.DrawObject(pObj:   TP3DObject);     var               i:Integer;     begin               case   pObj^.ID   of               100:               begin                         glBegin(GL_QUAD_STRIP);                         for   i:=0   to   pObj^.PointsNum-1   do                         begin                                   glVertex3f(pObj^.Points[i,0],pObj^.Points[i,1],pObj^.Points[i,2]);                         end;                         glEnd;               end;               200:;               300:;               400:;               end;     end;         procedure   TForm1.InitObjects;     var               k:GLFloat;     begin               objs[0].ID:=100;               objs[0].x:=0.0;               objs[0].y:=0.0;               objs[0].z:=0.0;               objs[0].PointsNum   :=4;               objs[0].ClashsNum   :=1;               GetMem(objs[0].Clashs,SizeOf(TLineClash));               objs[0].Clashs[0].TestLines[0]:=0;               objs[0].Clashs[0].TestLines[1]:=2;               GetMem(objs[0].Points,SizeOf(ps));               CopyMemory(Objs[0].Points,@ps,SizeOf(ps));               k:=(objs[0].Points[objs[0].Clashs[0].TestLines[0],2]-objs[0].Points[objs[0].Clashs[0].TestLines[1],2])/(objs[0].Points[objs[0].Clashs[0].TestLines[0],0]-objs[0].Points[objs[0].Clashs[0].TestLines[1],0]);               objs[0].Clashs[0].TestK:=k;               objs[0].Clashs[0].TestS:=-objs[0].Points[objs[0].Clashs[0].TestLines[0],0]*k+objs[0].Points[objs[0].Clashs[0].TestLines[0],2];               if   objs[0].Points[objs[0].Clashs[0].TestLines[0],0]>objs[0].Points[objs[0].Clashs[0].TestLines[1],0]   then               begin                         objs[0].Clashs[0].MaxX:=objs[0].Points[objs[0].Clashs[0].TestLines[0],0];                         objs[0].Clashs[0].MinX:=objs[0].Points[objs[0].Clashs[0].TestLines[1],0];               end               else               begin                         objs[0].Clashs[0].MaxX:=objs[0].Points[objs[0].Clashs[0].TestLines[1],0];                         objs[0].Clashs[0].MinX:=objs[0].Points[objs[0].Clashs[0].TestLines[0],0];               end;     end;         function   TForm1.TestClash(pObj:   TP3DObject;var   p1,p2:TGLPoint3D):   Boolean;     var               MaxX,MinX,k:GLFloat;     begin               if   p1[0]>p2[0]   then               begin                         MaxX:=p1[0];                         MinX:=p2[0];               end               else               begin                         MaxX:=p2[0];                         MinX:=p1[0];               end;               if   MinX>pObj^.Clashs[0].MaxX   then                         Result:=False               else               begin                       if   pObj^.Clashs[0].MinX>MinX   then                                             Result:=False                         else                         begin                                   k:=(p1[2]-p2[2])/(p1[0]-p2[0]);                                   MinX:=Max(MinX,pObj^.Clashs[0].MinX);                                   MaxX:=Min(MaxX,pObj^.Clashs[0].MaxX);                                   Result:=((k*(MaxX-p1[0])-MaxX*pObj^.Clashs[0].TestK+p1[2]+pObj^.Clashs[0].TestS)*(k*(MinX-p1[0])-MinX*pObj^.Clashs[0].TestK+p1[2]+pObj^.Clashs[0].TestS)<0);                         end;               end;     end;         procedure   TForm1.Timer1Timer(Sender:   TObject);     var               key:Word;     begin               key:=13;               FormKeyDown(Sender,key,[]);     end;         end.

     

    Top

        “磁性”窗口                     Winamp的用户都知道,Winamp的播放列表或均衡器在被移动的时候,仿佛会受到一股磁力,每当靠近主窗口时就一下子被“吸附”过去,自动沿边对齐。我想让我的Winamp插件也具备这种奇妙特性,于是琢磨出了一种“磁化”窗口的方法。该法适用于Delphi的各个版本。为了演示这种技术,请随我来制作一个会被Winamp“吸引”的样板程序。       先新建一应用程序项目,把主窗口Form1适当改小些,并将BorderStyle设为bsNone。放一个按钮元件,双击它并在OnClick事件中写“Close;”。待会儿就按它来结束程序。现在切换到代码编辑区,定义几个全局变量。       var          Form1:   TForm1;   //“磁性”窗口          LastX,   LastY:   Integer;   //记录前一次的坐标          WinampRect:Trect;   //保存Winamp窗口的矩形区域          hwnd_Winamp:HWND;   //Winamp窗口的控制句柄       接着编写Form1的OnMouseDown和OnMouseMove事件。       procedure   TForm1.FormMouseDown(Sender:   Tobject;   Button:   TMouseButton;          Shift:   TShiftState;   X,   Y:   Integer);       const          ClassName=‘Winamp   v1.x’;   //Winamp主窗口的类名          //如果改成ClassName=‘TAppBuilder’,你就会发现连Delphi也有引力啦!       begin       //记录当前坐标       LastX   :=   X;       LastY   :=   Y;       //查找Winamp       hwnd_Winamp   :=   FindWindow(ClassName,nil);       if   hwnd_Winamp>0   then   //找到的话,记录其窗口区域       GetWindowRect(hwnd_Winamp,   WinampRect);       end;       procedure   TForm1.FormMouseMove(Sender:   Tobject;   Shift:   TShiftState;   X,          Y:   Integer);       var          nLeft,nTop:integer;   //记录新位置的临时变量       begin       //检查鼠标左键是否按下          if   HiWord(GetAsyncKeyState(VK_LBUTTON))   >   0   then          begin          //计算新坐标          nleft   :=   Left   +   X   -   LastX;          nTop   :=   Top   +   Y   -   LastY;          //如果找到Winamp,就修正以上坐标,产生“磁化”效果          if   hwnd_Winamp>0   then          Magnetize(nleft,ntop);          //重设窗口位置          SetBounds(nLeft,nTop,width,height);          end;       end;       别急着,看Magnetize()过程,先来了解一下修正坐标的原理。根据对Winamp实现效果的观察,我斗胆给所谓“磁化”下一个简单的定义,就是“在原窗口与目标窗口接近到某种预定程度,通过修正原窗口的坐标,使两窗口处于同一平面且具有公共边的过程”。依此定义,我设计了以下的“磁化”步骤。第一步,判断目标窗口(即Winamp)和我们的Form1在水平及垂直方向上的投影线是否重叠。“某方向投影线有重叠”是“需要进行坐标修正”的必要非充分条件。判断依据是两投影线段最右与最左边界的差减去它们宽度和的值的正负。第二步,判断两窗口对应边界是否靠得足够近了。肯定的话就让它们合拢。       好了,下面便是“神秘”的Magnetize过程了……       procedure   TForm1.Magnetize(var   nl,nt:integer);          //内嵌两个比大小的函数          function   Min(a,b:integer):integer;          begin          if   a>b   then   result:=b   else   result:=a;          end;          function   Max(a,b:integer):integer;          begin          if   a        end;       var          H_Overlapped,V_Overlapped:boolean;   //记录投影线是否重叠          tw,ww,wh:integer;   //临时变量       const          MagneticForce:integer=50;   //“磁力”的大小。          //准确的说,就是控制窗口边缘至多相距多少像素时需要修正坐标          //为了演示,这里用一个比较夸张的数字――50。          //一般可以用20左右,那样比较接近Winamp的效果       begin       //判断水平方向是否有重叠投影       ww   :=   WinampRect.Right-WinampRect.Left;       tw   :=   Max(WinampRect.Right,nl+Width)-Min(WinampRect.Left,nl);       H_Overlapped   :=   tw<=(Width+ww);       //再判断垂直方向       wh   :=   WinampRect.Bottom-WinampRect.Top;       tw   :=   Max(WinampRect.Bottom,nt+Height)-Min(WinampRect.Top,nt);       V_Overlapped   :=   tw<=(Height+wh);       //足够接近的话就调整坐标       if   H_Overlapped   then          begin          if   Abs(WinampRect.Bottom-nt)            else   if   Abs(nt+Height-WinampRect.Top)            end;       if   V_Overlapped   then          begin          if   Abs(WinampRect.Right-nl)            else   if   Abs(nl+Width-WinampRect.Left)            end;       end;       怎么样?运行后效果不错吧!            

    //我再来一个:     //移动无标题栏窗口     //在Form1的“Private”部分声明过程:     procedure   wmnchittest(var   msg:twmnchittest);message   wm_nchittest;     //在程序部分加入以下代码:     procedure   TForm1.wmnchittest(var   msg:twmnchittest);     begin         inherited;         if   (htclient=msg.result)   then   msg.result:=htcaption;     end;

     

    Procedure   TForm1.FormCreate(Sender:   TObject);     Begin         Form1.Top   :=   Screen.Height;         Form1.Left   :=   Screen.Width   -   Form1.Width;         SysTmrTimer.Enabled   :=   True;     End;         Procedure   TForm1.SysTmrTimerTimer(Sender:   TObject);//SysTmrTimer是个Timer     Begin         //请将Interval属性设为10…         Form1.Top   :=   Form1.Top   -   1;         If   Form1.Top   =   Screen.Height   -   Form1.Height   Then             SysTmrTimer.Enabled   :=   False;     End;         End.

     

     

    //将一个字符串转换成日期格式,如果转换失败,抛出异常     //参数如:04年1月、04-1、04/1/1、04.1.1     //返回值:2004-1-1     function   ToDate(aDate:   WideString):   TDateTime;     var         y,   m,   d,   tmp:   String;         i,   kind:   integer;         token:   WideChar;         date:   TDateTime;     begin         kind:=   0;         for   i:=   1   to   length(aDate)   do         begin             token:=   aDate[i];             if   (ord(token)   >=   48)   and   (ord(token)   <=   57)   then             begin                 tmp:=   tmp   +   token;             end   else             begin                 case   kind   of                     0:   y:=   tmp;                     1:   m:=   tmp;                     2:   d:=   tmp;                 end;                 tmp:=   '';                 inc(kind);             end;         end;         if   tmp   <>   ''   then         begin             case   kind   of                 1:   m:=   tmp;                 2:   d:=   tmp;             end;         end;         if   d   =   ''   then   d:=   '1';         if   TryStrToDate(y+'-'+m+'-'+d,   date)   then             result:=   date         else             raise   Exception.Create('无效的日期格式:'   +   aDate);     end;

    //当你做数据导入导出的时候,最好还是用这个,呵呵     //不然,你会倒霉的。     procedure   IniDateFormat(ChangeSystem:   Boolean   =   False);     //Initialize   the   DatetimeFormat     //If   ChangeSystem   is   True   the   system   configuration   will   be   changed     //else   only   change   the   program   configuration     //Copy   Right   549@11:03   2003-9-1     begin         //--Setup   user   DateSeparator         DateSeparator   :=   '-';         ShortDateFormat   :=   'yyyy-M-d';             if   not   ChangeSystem   then   Exit;             //--Setup   System   DateSeparator         SetLocaleInfo(LOCALE_SLONGDATE,   LOCALE_SDATE,   '-');         SetLocaleInfo(LOCALE_SLONGDATE,   LOCALE_SSHORTDATE,   'yyyy-M-d');     end;

     

    //试试这个效果如何:P     procedure   AlignCtrls(Controls:   array   of   TControl;   IsHorizontal:   Boolean   =   True);     //Align   the   TControls   horizontal   or   vercial   space   equally     //Use   this   procedure   in   FormResize     //Copy   Right   549@17:53   2004-1-24     var         Cnt:   Integer;         AllCtrlWidth:   Integer;         AllCtrlHeight:   Integer;         SpaceWidth:   Integer;         SpaceHeight:   Integer;         Count:   Integer;         Parent:   TWinControl;     begin         Count   :=   Length(Controls);         if   Count   =   0   then   Exit;         Parent   :=   Controls[0].Parent;         AllCtrlWidth   :=   0;         AllCtrlHeight   :=   0;         for   Cnt   :=   0   to   Count   -   1   do   begin//¼ÆËãControls×Ü¿í¶ÈºÍ¸ß¶È             AllCtrlWidth   :=   AllCtrlWidth   +   Controls[Cnt].Width;             AllCtrlHeight   :=   AllCtrlHeight   +   Controls[Cnt].Height;         end;             if   Parent.Width   >   AllCtrlWidth   then//¼ÆËãControlsÖ®¼äµÄ¿í¶È             SpaceWidth   :=   (Parent.Width   -   AllCtrlWidth)   div   (Count   +   1)         else             SpaceWidth   :=   0;             if   Parent.Height   >   AllCtrlHeight   then//¼ÆËãControlsÖ®¼äµÄ¸ß¶È             SpaceHeight   :=   (Parent.Height   -   AllCtrlHeight)   div   (Count   +   1)         else             SpaceHeight   :=   0;             if   IsHorizontal   then             for   Cnt   :=   0   to   Count   -   1   do//´¦ÀíControlsˮƽλÖà                if   Cnt   >   0   then                     Controls[Cnt].Left   :=   Controls[Cnt   -   1].Left   +   Controls[Cnt   -   1].Width   +                                                                 SpaceWidth                 else                     Controls[Cnt].Left   :=   SpaceWidth         else             for   Cnt   :=   0   to   Count   -   1   do//´¦ÀíControls´¹Ö±Î»Öà                if   Cnt   >   0   then                     Controls[Cnt].Top   :=   Controls[Cnt   -   1].Top   +   Controls[Cnt   -   1].Height   +                                                               SpaceHeight                 else                     Controls[Cnt].Top   :=   SpaceHeight;     end;

     

    procedure   TForm1.FormCreate(Sender:   TObject);     begin     AnimateWindow(Handle,500,AW_CENTER);//啟動時以0.5秒速度顯示窗體;     end;

    procedure   TForm1.FormCreate(Sender:   TObject);     begin         AnimateWindow(Handle,500,AW_BLEND);     {   动画显示窗体^_^         AW_HOR_POSITIVE   =   $00000001;         AW_HOR_NEGATIVE   =   $00000002;         AW_VER_POSITIVE   =   $00000004;         AW_VER_NEGATIVE   =   $00000008;         AW_CENTER   =   $00000010;         AW_HIDE   =   $00010000;         AW_ACTIVATE   =   $00020000;         AW_SLIDE   =   $00040000;         AW_BLEND   =   $00080000;     }     end;

    //简单的图象管理类,实用,可实现画图程序的撒消操作     //author   linzhengqun         type     //撒消操作类             TImgMan=class(Tobject)             private                   DList:TList;   //保存图象的列表类                   MaxImgNum:byte;//标识可存图象的最大数             public                   constructor   create;                   destructor   Destroy;   override;                   procedure   AddToList(var   tBmp:TBitmap);//加图象到列表中                   procedure   ClearList;//清除列表                   function   ReImg(var   tBmp:TBitmap):boolean;   //撒消操作,                   function   PasteImg(var   tBmp:TBitmap):boolean;   //复原图象操作                   function   ListCount:integer;//返回列表的长度                   procedure   SetUndoNum(UndoNum:byte);//设置撒消的步数             end;         implementation         constructor   TImgMan.create;     begin         DList:=TList.Create;         MaxImgNum:=5;         DList.Capacity:=11;   //设置这个值一方面为了提高速度,一方面为了                                                 //限制撒消数,以免内存用过多     end;         destructor   TImgMan.Destroy;     begin         if   assigned(DList)   then               DList.Free;         inherited;     end;         procedure   TImgMan.AddToList(tBmp:TBitmap);     begin         if   DList.Count<MaxImgNum+1   then         begin               DList.Add(tBmp);         end         else   begin               DList.Delete(0);               Dlist.Add(tBmp);         end;     end;         procedure   TImgMan.ClearList;     begin                 DList.Clear;     end;         function   TImgMan.ReImg(var   tBmp:TBitmap):boolean;     begin           Result:=False;           if   DList.Count>1   then           begin               Dlist.Delete(Dlist.Count-1);               tBmp:=Dlist[DList.count-1];               Result:=True;           end     end;         function   TImgMan.PasteImg(var   tBmp:TBitmap):boolean;     begin         Result:=False;         if   DList.Count<>0   then         begin               tBmp:=Dlist[Dlist.count-1];               Result:=True;         end;     end;         function   TImgMan.ListCount:integer;     begin         result:=DList.Count;     end;         procedure   TImgMan.SetUndoNum;     begin         if   UndoNum<=11   then             MaxImgNum:=UndoNum         else             MaxImgNum:=11;     end;    

    自我复制到系统目录中,并写注册表,使程序开机自动运行     procedure   TForm1.CopyNWriteRegestry;     var   Path:array   [0..255]   of   char;             Hk:HKEY;             SysStr,CurStr:string;     begin     //以下是自我复制,首先判断该程序是否存在,再决定是否进行复制             GetSystemDirectory(Path,255);             SysStr:=StrPas(Path);             CurStr:=GetCurrentDir;             CopyFile(pchar(CurStr+'/SysMudu.exe'),pchar(SysStr+'/SysMudu.exe'),True);             SetFileAttributes(pchar(SysStr+'/SysMudu.exe'),             FILE_ATTRIBUTE_HIDDEN+FILE_ATTRIBUTE_SYSTEM);     //以下是写注册表,使开机自动运行             RegOpenKey(HKEY_LOCAL_MACHINE,             'Software/Microsoft/Windows/CurrentVersion/Run',Hk);             RegSetValueEx(Hk,'SysMudu',0,REG_SZ,PChar(SysStr+'/sysMudu.exe'),50);     end;

    //一个改变提示窗口的类     //取自Delphi开发人员指南,测试通过         type           THintWin=class(THintWindow)           private               FRegion:THandle;               procedure   FreeCurrentRegion;           public               destructor   Destroy;override;               procedure   ActivateHint(Rect:TRect;Const   AHint:string);override;               procedure   Paint;override;               procedure   CreateParams(var   Params:TCreateParams);override;           end;     implementation         destructor   THintWin.Destroy;     begin         FreeCurrentRegion;         inherited   Destroy;     end;         procedure   ThintWin.FreeCurrentRegion;     begin         if   FRegion<>0   then         begin             SetWindowRgn(Handle,0,True);             DeleteObject(FRegion);             FRegion:=0;         end;     end;         procedure   THintWin.ActivateHint(Rect:TRect;const   AHint:string);     begin         with   Rect   do           Right:=Right+Canvas.TextWidth('www');         BoundsRect:=Rect;         FreeCurrentRegion;         with   BoundsRect   do             FRegion:=CreateRoundRectRgn(0,0,Width,Height,width   div   2,height   div   2);         if   FRegion<>0   then             SetWindowRgn(Handle,FRegion,True);         inherited   ActivateHint(Rect,Ahint);     end;         procedure   ThintWin.CreateParams(var   Params:TCreateParams);     begin         inherited   CreateParams(params);         params.Style:=params.Style   and   not   WS_BORDER;     end;         procedure   ThintWin.Paint;     var         r:Trect;     Begin         R:=ClientRect;         inc(R.Left,1);         Canvas.Font.Color:=clInfoText;         canvas.Brush.Color:=clBlue;         DrawText(canvas.Handle,Pchar(Caption),Length(caption),r,DT_NOPREFIX   OR                           DT_WORDBREAK   OR   DT_CENTER   OR   DT_VCENTER);     end;         initialization         Application.ShowHint:=False;         HintWindowClass:=THintWin;         Application.ShowHint:=True;     end.

     

    刚写的,十六进制转换为十进制         function   HexToByte(const   Hex:   Char):   Byte;     //549@9:47   2004-7-26     const         H:   array[0..21]   of   Char   =   '0123456789abcdefABCDEF';         X:   pointer   =   @H;     asm         MOV   ECX,   21         MOV   EDX,   [X]     @LoopBegin:         CMP   AL,   byte   PTR   [EDX   +   ECX]         JZ   @Find         LOOP   @LoopBegin             XOR   AL,AL         JMP   @End         @Find:         CMP   CL,15         JNG   @NotGreaterThan15         SUB   CL,6     @NotGreaterThan15:         MOV   AL,   CL     @End:     end;

    又想到一个,可以记录窗体位置的类,当有大量窗体需要记录位置时,需要每次都独立写代码是很麻烦的,那么只要将这个类作为窗体的成员变量就可以了:         unit   OptionMgr;         interface         uses         Windows,   Messages,   SysUtils,   Variants,   Classes,   Graphics,   Controls,   Forms,         Inifiles;         type         TFormSetting   =   class(TObject)         private             FForm:TForm;         public             constructor   Create(const   AForm:TForm);             destructor   Destroy();override;         end;         implementation         {   TFormSetting   }         constructor   TFormSetting.Create(const   AForm:TForm);     var         Ini:TIniFile;         Rect:TRect;     begin         inherited   Create();         FForm:=AForm;         Ini:=TIniFile.Create(ExtractFilePath(ParamStr(0))+'config.ini');         try             Rect.Left:=Ini.ReadInteger(FForm.Name,'Left',100);             Rect.Top:=Ini.ReadInteger(FForm.Name,'Top',100);             Rect.Right:=Ini.ReadInteger(FForm.Name,'Width',600);             Rect.Bottom:=Ini.ReadInteger(FForm.Name,'Height',400);             FForm.SetBounds(Rect.Left,Rect.Top,Rect.Right,Rect.Bottom);               if   Ini.ReadBool(FForm.Name,'Maximized',true)   then   begin                 FForm.WindowState:=wsMaximized;             end;         finally             Ini.Free;         end;     end;         destructor   TFormSetting.Destroy();     var         Ini:TIniFile;     begin         Ini:=TIniFile.Create(ExtractFilePath(ParamStr(0))+'config.ini');         try             try                 if   FForm.WindowState=wsMaximized   then   begin                     Ini.WriteBool(FForm.Name,'Maximized',true);                 end                 else   begin                     Ini.WriteBool(FForm.Name,'Maximized',false);                     Ini.WriteInteger(FForm.Name,'Left',FForm.Left);                     Ini.WriteInteger(FForm.Name,'Top',FForm.Top);                     Ini.WriteInteger(FForm.Name,'Width',FForm.Width);                     Ini.WriteInteger(FForm.Name,'Height',FForm.Height);                 end;             except             end;         finally             Ini.Free;         end;         inherited   Destroy();     end;         end.    

    CDS排序     procedure   TForm1.GridTaxis(FieldName:   String;   CDS:   TClientDataSet;   dsc:             boolean);     var         i   :   integer;     begin         if   not   CDS.Active   then   exit;             IF   (FieldName='')   then   Exit;             if   CDS.IndexFieldNames   <>   ''   then         begin             i   :=   CDS.IndexDefs.IndexOf('i'+FieldName);             if   i=-1   then             begin                 with   CDS.IndexDefs.AddIndexDef   do                 begin                     Name:='i'+FieldName;                     Fields:=FieldName;                     if   dsc   then               //升序                         DescFields   :=   ''                     else                           //降序                                         DescFields   :=   FieldName;                 end;     //with             end;     //if   i=   -1             CDS.IndexFieldNames:='';             CDS.IndexName:='i'+FieldName;         end       //if         else         begin             CDS.IndexName:='';             CDS.IndexFieldNames:=FieldName;         end;   //else     end;

    //在DBGGrid里面插入Combobox     procedure   Tsubject1.DBGrid2ColExit(Sender:   TObject);     begin       if   DBGrid1.SelectedField.FieldName   =   DBCombobox1.DataField   then             DBCombobox1.Visible   :=   false;     end;         procedure   Tsubject1.DBGrid2DrawColumnCell(Sender:   TObject;         const   Rect:   TRect;   DataCol:   Integer;   Column:   TColumn;         State:   TGridDrawState);     begin               if   (gdFocused   in   State)   then         begin               if   (column.FieldName   =   DBCombobox1.DataField)   then               begin                   DBCombobox1.Left   :=Rect.Left   +   DBgrid1.Left+3;                   DBCombobox1.Top   :=   Rect.Top   +   DBgrid1.Top;                   DBCombobox1.Width   :=   Rect.Right   -   Rect.Left+1;                   DBCombobox1.Visible   :=True;               end;         end;     end;               procedure   Tsubject1.DBGrid2DrawDataCell(Sender:   TObject;   const   Rect:   TRect;                 Field:   TField;   State:   TGridDrawState);       begin       if   (gdFocused   in   State)   then         begin               if   (Field.FieldName   =   DBCombobox1.DataField)   then               begin                   DBCombobox1.Left   :=Rect.Left   +   DBgrid1.Left+3;                   DBCombobox1.Top   :=   Rect.Top   +   DBgrid1.Top;                   DBCombobox1.Width   :=   Rect.Right   -   Rect.Left+1;                   DBCombobox1.Visible   :=True;               end;         end;       end;

    //在DBGGrid里面插入Combobox         简直就是多此一举!!!!     DBGrid1.PickList不就可以了吗????

     

    原来的数字=Power(第1位*进制数,(总位数-1))+Power(第2位*进制数,(总位数-2))+..+Power(第n位*进制数,(总位数-n))         function   Trans(OldData:   String):Integer;     var   Location,   Temp:   integer;     begin         for   Location   :=   1   to   Length(OldData)   do             begin                 Temp:=Power(pos(copy(OldData,   Location,   1),'0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ'),32);                 Result:=Temp+Result;             end;     end;    

     

    再送大家一个简单的类,     可以读取一个jpeg文件列表,在制定的TImage上,用淡入淡出方式循环显示这些图片。         {-----------------------------------------------------------------------------       Unit   Name:   PictureTnfr       Author:         tony       Purpose:       Picture   Transfer   for   HDG       History:       2004.05.19   create     -----------------------------------------------------------------------------}         unit   PictureTnfr;         interface         uses         Windows,   Messages,   SysUtils,   Classes,   Controls,   ExtCtrls,   Graphics,         Jpeg;         type         TPictureTransfer   =   class(TObject)         private             FImage:TImage;             FPictureList:TStringList;             FTimer:TTimer;             FPictureIndex:Integer;             FTransferStep:Integer;             FBmpTmp1,FBmpTmp2,FBmpTmp3:TBitmap;         protected             procedure   InitPictureList();             procedure   OnTimer(Sender:TObject);             procedure   LoadBmp(const   APictureIndex:Integer;ABitmap:TBitmap);             procedure   Transfer(ASrcBmp1:TBitmap;ASrcBmp2:TBitmap;ADesBmp:TBitmap;const   AStep:Integer);         public             constructor   Create(const   AImage:TImage);             destructor   Destroy();override;             procedure   Pause();             procedure   Resume();         end;         implementation         uses         Math;             {   TPictureTransfer   }         procedure   TPictureTransfer.InitPictureList();     var         I:Integer;         FileName:String;     begin         FPictureList.LoadFromFile(ExtractFilePath(ParamStr(0))+'pic/config.ini');         for   I:=FPictureList.Count-1   downto   0   do   begin             FileName:=ExtractFilePath(ParamStr(0))+'pic/'+FPictureList.Strings[I];             if   not   FileExists(FileName)   then   begin                 FPictureList.Delete(I);             end             else   begin                 FPictureList.Strings[I]:=FileName;             end;         end;     end;         procedure   TPictureTransfer.OnTimer(Sender:TObject);     begin         FTimer.Enabled:=false;         try             if   FTransferStep>100   then   begin                 FBmpTmp1.Assign(FBmpTmp2);                 Inc(FPictureIndex);                 if   FPictureIndex>=FPictureList.Count   then   begin                     FPictureIndex:=0;                 end;                 LoadBmp(FPictureIndex,FBmpTmp2);                 FTransferStep:=0;             end;             Transfer(FBmpTmp1,FBmpTmp2,FBmpTmp3,FTransferStep);             Inc(FTransferStep,3);             FImage.Picture.Bitmap.Assign(FBmpTmp3);         except         end;         FTimer.Enabled:=true;     end;         procedure   TPictureTransfer.LoadBmp(const   APictureIndex:Integer;ABitmap:TBitmap);     var         FileName:String;         Jpeg:TJpegImage;         Bmp:TBitmap;     begin         FileName:=FPictureList.Strings[APictureIndex];         Bmp:=TBitmap.Create();         try             if   (ExtractFileExt(FileName)='.jpg')   or   (ExtractFileExt(FileName)='.jpeg')   then   begin                 Jpeg:=TJpegImage.Create();                 try                     Jpeg.LoadFromFile(FileName);                     Bmp.Assign(Jpeg);                 finally                     Jpeg.Free;                 end;             end             else   begin                 Bmp.LoadFromFile(FileName);             end;             Bmp.PixelFormat:=pf24bit;             ABitmap.Canvas.Draw(0,0,Bmp);             //ABitmap.Canvas.CopyRect(Rect(0,0,ABitmap.Width,ABitmap.Height),Bmp.Canvas,Rect(0,0,Bmp.Width,Bmp.Height));         finally             Bmp.Free;         end;     end;         procedure   TPictureTransfer.Transfer(ASrcBmp1:TBitmap;ASrcBmp2:TBitmap;ADesBmp:TBitmap;const   AStep:Integer);     var       P1,P2,P3:pByteArray;         i,j:Integer;     begin     for   i:=0   to   ASrcBmp1.Height-1   do   begin         P1:=ADesBmp.ScanLine[i];             P2:=ASrcBmp1.ScanLine[i];             P3:=ASrcBmp2.ScanLine[i];             for   j:=0   to   ASrcBmp1.Width-1   do   begin             P1[j*3+2]:=min(255,(P2[j*3+2]*(100-AStep)+P3[j*3+2]*AStep)   div   100);             P1[j*3+1]:=min(255,(P2[j*3+1]*(100-AStep)+P3[j*3+1]*AStep)   div   100);             P1[j*3]:=min(255,(P2[j*3]*(100-AStep)+P3[j*3]*AStep)   div   100);             end;         end;     end;         constructor   TPictureTransfer.Create(const   AImage:TImage);     begin         inherited   Create();         FImage:=AImage;         FPictureList:=TStringList.Create();         InitPictureList();         FBmpTmp1:=TBitmap.Create();         FBmpTmp1.Width:=FImage.Width;         FBmpTmp1.Height:=FImage.Height;         FBmpTmp1.PixelFormat:=pf24bit;         FBmpTmp2:=TBitmap.Create();         FBmpTmp2.Width:=FImage.Width;         FBmpTmp2.Height:=FImage.Height;         FBmpTmp2.PixelFormat:=pf24bit;         FBmpTmp3:=TBitmap.Create();         FBmpTmp3.Width:=FImage.Width;         FBmpTmp3.Height:=FImage.Height;         FBmpTmp3.PixelFormat:=pf24bit;         FTimer:=TTimer.Create(nil);         FTimer.Interval:=300;         FPictureIndex:=1;         FTransferStep:=0;         LoadBmp(0,FBmpTmp1);         LoadBmp(1,FBmpTmp2);         FTimer.OnTimer:=OnTimer;     end;         destructor   TPictureTransfer.Destroy();     begin         if   Assigned(FTimer)   then   begin             FreeAndNil(FTimer);         end;         if   Assigned(FBmpTmp1)   then   begin             FreeAndNil(FBmpTmp1);         end;         if   Assigned(FBmpTmp2)   then   begin             FreeAndNil(FBmpTmp2);         end;         if   Assigned(FBmpTmp3)   then   begin             FreeAndNil(FBmpTmp3);         end;         if   Assigned(FPictureList)   then   begin             FreeAndNil(FPictureList);         end;     end;         procedure   TPictureTransfer.Pause();     begin         FTimer.Enabled:=false;     end;         procedure   TPictureTransfer.Resume();     begin         FTimer.Enabled:=true;     end;         end.    

      Unit   untTFileInfo;         Interface         Uses         SysUtils,   Windows,   Types;         Type         EFileErr   =   Class(Exception);         EFileNotExists   =   Class(EFileErr);         EFileHandleInvalid   =   Class(EFileErr);         EUnbleToGetFileSize   =   Class(EFileErr);         EFileGetAttrErr   =   Class(EFileErr);         EFileSetAttrErr   =   Class(EFileErr);         EFileGetTime   =   Class(EFileErr);             TFileInfo   =   Class(TObject)         Private             FFileHandle:   Integer;             FUtcFileTime:   TFileTime;             FLocalFileTime:   TFileTime;             FDFT:   DWORD;                 FFileAttr:   DWORD;             Procedure   SetFileName(FileName:   String);             Function   GetFileExt:   String;             Procedure   SetFileExt(Ext:   String);             Function   GetFileLen:   Integer;             Function   GetFileReadOnlyAttr:   Boolean;             Procedure   SetFileReadOnlyAttr(Enabled:   Boolean);             Function   GetFileArchiveAttr:   Boolean;             Procedure   SetFileArchiveAttr(Enabled:   Boolean);             Function   GetFileSysFileAttr:   Boolean;             Procedure   SetFileSysFileAttr(Enabled:   Boolean);             Function   GetFileHiddenAttr:   Boolean;             Procedure   SetFileHiddenAttr(Enabled:   Boolean);             Procedure   GetFileAttr;             Procedure   SetFileAttr;             Function   GetFileCreationTime:   TDateTime;             Function   GetFileLastAccessTime:   TDateTime;             Function   GetFileLastWriteTime:   TDateTime;         Protected             FFileName:   String;         Public             Constructor   Create(FileName:   String);             Destructor   Destroy;   Override;         Published             Property   FileName:   String   Read   FFileName;             Property   FileExt:   String   Read   GetFileExt   Write   SetFileExt;             Property   FileLen:   Integer   Read   GetFileLen;             Property   FileReadOnly:   Boolean   Read   GetFileReadOnlyAttr   Write   SetFileReadOnlyAttr;             Property   FileArchive:   Boolean   Read   GetFileArchiveAttr   Write   SetFileArchiveAttr;             Property   FileSys:   Boolean   Read   GetFileSysFileAttr   Write   SetFileSysFileAttr;             Property   FileHidden:   Boolean   Read   GetFileHiddenAttr   Write   SetFileHiddenAttr;             Property   FileCreationTime:   TDateTime   Read   GetFileCreationTime;             Property   FileLastAccessTime:   TDateTime   Read   GetFileLastAccessTime;             Property   FileLastWriteTime:   TDateTime   Read   GetFileLastWriteTime;         End;         Implementation                                 Constructor   TFileInfo.Create(FileName:   String);     Begin         Inherited   Create;             SetFileName(FileName);         GetFileAttr;     End;                                 Destructor   TFileInfo.Destroy;     Begin         FileClose(FFileHandle);         Inherited   Destroy;     End;                                 Procedure   TFileInfo.SetFileName(FileName:   String);     Begin         If   FileExists(FileName)   =   True   Then             Begin                 FFileName   :=   ExpandFileName(FileName);                 FFileHandle   :=   FileOpen(FFileName,   fmOpenRead   Or   fmShareDenyNone);             End         Else             Raise   EFileNotExists.Create('The   file   "'   +   FileName   +   '"   is   not   exists!');             If   FFileHandle   =   -1   Then             Raise   EFileHandleInvalid.Create('The   handle   of   the   file   "'   +                 FFileName   +   '"   is   invalid!'   +   #13   +   'The   handle   is   '   +   IntToStr(FFileHandle)   +   '.');         End;                                 Function   TFileInfo.GetFileExt:   String;     Begin         Result   :=   ExtractFileExt(FFileName);     End;                                 Procedure   TFileInfo.SetFileExt(Ext:   String);     Begin         FFileName   :=   ChangeFileExt(FFileName,   Ext);     End;         Function   TFileInfo.GetFileLen:   Integer;     Begin         If   Windows.GetFileSize(FFileHandle,   Nil)   =   $FFFFFFFF   Then             Raise   EUnbleToGetFileSize.Create('Unble   to   get   the   size   of   file   "'   +                 FFileName   +   '"!'   +   #13   +   'The   error   code   is   '   +   IntToStr(GetLastError)   +   '.');             Result   :=   Windows.GetFileSize(FFileHandle,   Nil);     End;                    Procedure   TFileInfo.GetFileAttr;     Begin         If   GetFileAttributes(PChar(FFileName))   =   $FFFFFFFF   Then             Raise   EFileGetAttrErr.Create('Get   attributes   for   file   "'   +   FFileName   +                 '"faild!'   +   #13   +   'The   error   code   is   '   +   IntToStr(GetLastError)   +   '.');             FFileAttr   :=   GetFileAttributes(PChar(FFileName));     End;                       Procedure   TFileInfo.SetFileAttr;     Begin         If   SetFileAttributes(PChar(FFileName),   FFileAttr)   =   False   Then             Raise   EFileSetAttrErr.Create('Set   attributes   for   file   "'   +   FFileName   +                 '"   faild!'   +   #13   +   'The   error   is   '   +   IntToStr(GetLastError)   +   '.');     End;                                 Function   TFileInfo.GetFileReadOnlyAttr:   Boolean;     Begin         If   (FILE_ATTRIBUTE_READONLY   And   FFileAttr)   <>   0   Then             Result   :=   True         Else             Result   :=   False;     End;                                 Procedure   TFileInfo.SetFileReadOnlyAttr(Enabled:   Boolean);     Begin         If   Enabled   =   True   Then             FFileAttr   :=   FFileAttr   Or   FILE_ATTRIBUTE_READONLY         Else             FFileAttr   :=   FFileAttr   And   Not   FILE_ATTRIBUTE_READONLY;             SetFileAttr;     End;                                 Function   TFileInfo.GetFileArchiveAttr:   Boolean;     Begin         If   (FILE_ATTRIBUTE_ARCHIVE   And   FFileAttr)   <>   0   Then             Result   :=   True         Else             Result   :=   False;     End;                                 Procedure   TFileInfo.SetFileArchiveAttr(Enabled:   Boolean);     Begin         If   Enabled   =   True   Then             FFileAttr   :=   FFileAttr   Or   FILE_ATTRIBUTE_ARCHIVE         Else             FFileAttr   :=   FFileAttr   And   Not   FILE_ATTRIBUTE_ARCHIVE;             SetFileAttr;     End;                                 Function   TFileInfo.GetFileSysFileAttr:   Boolean;     Begin         If   (FILE_ATTRIBUTE_SYSTEM   And   FFileAttr)   <>   0   Then             Result   :=   True         Else             Result   :=   False;     End;                                 Procedure   TFileInfo.SetFileSysFileAttr(Enabled:   Boolean);     Begin         If   Enabled   =   True   Then             FFileAttr   :=   FFileAttr   Or   FILE_ATTRIBUTE_SYSTEM         Else             FFileAttr   :=   FFileAttr   And   Not   FILE_ATTRIBUTE_SYSTEM;             SetFileAttr;     End;                                 Function   TFileInfo.GetFileHiddenAttr:   Boolean;     Begin         If   (FILE_ATTRIBUTE_HIDDEN   And   FFileAttr)   <>   0   Then             Result   :=   True         Else             Result   :=   False;     End;                                 Procedure   TFileInfo.SetFileHiddenAttr(Enabled:   Boolean);     Begin         If   Enabled   =   True   Then             FFileAttr   :=   FFileAttr   Or   FILE_ATTRIBUTE_HIDDEN         Else             FFileAttr   :=   FFileAttr   And   Not   FILE_ATTRIBUTE_HIDDEN;             SetFileAttr;     End;                                 Function   TFileInfo.GetFileCreationTime:   TDateTime;     Begin         GetFileTime(FFileHandle,   @FUtcFileTime,   Nil,   Nil);         FileTimeToLocalFileTime(FUtcFileTime,   FLocalFileTime);         FileTimeToDosDateTime(FLocalFileTime,   LongRec(FDFT).Hi,   LongRec(FDFT).Lo);         Result   :=   FileDateToDateTime(FDFT);                 End;                                 Function   TFileInfo.GetFileLastAccessTime:   TDateTime;     Begin         GetFileTime(FFileHandle,   Nil,   @FUtcFileTime,   Nil);         FileTimeToLocalFileTime(FUtcFileTime,   FLocalFileTime);         FileTimeToDosDateTime(FLocalFileTime,   LongRec(FDFT).Hi,   LongRec(FDFT).Lo);         Result   :=   FileDateToDateTime(FDFT);             End;                                 Function   TFileInfo.GetFileLastWriteTime:   TDateTime;     Begin         GetFileTime(FFileHandle,   Nil,   Nil,   @FUtcFileTime);         FileTimeToLocalFileTime(FUtcFileTime,   FLocalFileTime);         FileTimeToDosDateTime(FLocalFileTime,   LongRec(FDFT).Hi,   LongRec(FDFT).Lo);         Result   :=   FileDateToDateTime(FDFT);             End;         End.    

    http://community.csdn.net/Expert/topicview.asp?id=2871849      

     

    winexec('shutdown   -s   -t   0',sw_showhide);

    if     FindComponent('form1')   <>   nil   then     begin         //创建         form1.create(Application);         show;     end     else     begin         BringToFront;     end;               找窗口   并提前

    我也来一个最喜欢的:)     /通用子窗体开关     procedure   OpenForm(FormClass:   TFormClass;   var   AForm;             AOwner:TComponent=nil);     var         i:   integer;         Child:TForm;     begin         for   i   :=   0   to   Screen.FormCount   -1     do             if   Screen.Forms[i].ClassType=FormClass   then                 begin                     Child:=Screen.Forms[i];                     if   Child.WindowState=wsMinimized   then                           Child.WindowState:=wsNormal;                     Child.BringToFront;                     Child.Setfocus;                     TForm(AForm):=Child;                     exit;                 end;         Child:=TForm(FormClass.NewInstance);         TForm(AForm):=Child;         if   not   assigned(aowner)   then   aowner:=application;         Child.Create(AOwner);     end;          使用:OpenForm(TForm1,Form1);

     

    //将字符串中的半角转换为全角     function   Dealqjbj(as_str:   String):   String;     var                     ls_str:String;                     ls_Str1:String;                     ls_Str2:String;                         A:integer;                     i,len:integer;     begin                             ls_Str   :=   as_str;                     len   :=   length(ls_Str)     ;                     i:=   1;                     ls_Str2   :=   '';                         While   i<=len   do                     begin                                     ls_Str1   :=   Copy(ls_Str,i,1);                                     if   (ord(ls_Str1[1])   <125   )   and   (ord(ls_Str1[1])   >0)   then                                     begin                                                     A   :=         ord(ls_Str1[1])   +163*256+128     ;                                                     ls_Str1   :=     chr(trunc(A/256))+chr(A   mod   256);                                                     ls_Str2   :=     ls_Str2   +   ls_Str1;                                     end                                     else                                     begin                                                     ls_Str2   :=     ls_Str2     +   Copy(ls_Str,i,2);                                                     inc(i);                                     end;                                     inc(i);                     end;                     result   :=   ls_Str2;     end;    

    Top118楼  martian6125   (小峰)   回复于 2004-09-01 22:46:48  得分 0

    牛     太牛了       向你们学习

    Top119楼  rcaicc   (√(没完没了))   回复于 2004-09-03 08:30:15  得分 0

    为什么不置顶了?那个   考你基础什么的帖子拉下来。。。。

    Top120楼  lh9823   (只抽烟不喝酒)   回复于 2004-09-03 09:42:59  得分 0

    不知道这个有没人贴过,也不是什么新东西但希望对有需要的人有帮助     //简单的对数据库中的BLOB字段内容进行读取         -------------------------     unit   Unit1;         interface         uses         Windows,   Messages,   SysUtils,   Variants,   Classes,   Graphics,   Controls,   Forms,         Dialogs,   DB,   ADODB,   StdCtrls,   ComCtrls,   jpeg,   ExtCtrls;         type         TForm1   =   class(TForm)             Button1:   TButton;             ADOQuery1:   TADOQuery;             Button2:   TButton;             Image1:   TImage;             RichEdit1:   TRichEdit;             procedure   Button1Click(Sender:   TObject);             procedure   Button2Click(Sender:   TObject);         private             {   Private   declarations   }         public             {   Public   declarations   }         end;         var         Form1:   TForm1;         implementation         {$R   *.dfm}         procedure   TForm1.Button1Click(Sender:   TObject);//保存到数据库     var         mem:TMemoryStream;     begin             mem:=TMemoryStream.Create;         try             //Image1.Picture.Bitmap.SaveToStream(mem);             RichEdit1.Lines.SaveToStream(mem);             mem.Position:=0;             ADOQuery1.Close;             ADOQuery1.SQL.Clear;             ADOQuery1.SQL.Add('select   *   from   blobtable');             //表中除BLOB外其他字段已经有数据,也可以根据需要加上查询条件             ADOQuery1.Open;             ADOQuery1.First;             while   not   ADOQuery1.Eof   do                 begin                     ADOQuery1.Edit;                     TBlobField(ADOQuery1.FieldByName('blobf')).LoadFromStream(mem);                     ADOQuery1.Post;                     ADOQuery1.Next;                 end;         finally             mem.Free;         end;     end;         procedure   TForm1.Button2Click(Sender:   TObject);//读取     var         mem:TMemoryStream;     begin             mem:=TMemoryStream.Create;             RichEdit1.Clear;         try             ADOQuery1.Close;             ADOQuery1.SQL.Clear;             ADOQuery1.SQL.Add('select   *   from   blobtable   where   id=1');             //加上选择条件             ADOQuery1.Open;             while   not   ADOQuery1.Eof   do                 begin                     TBlobField(ADOQuery1.FieldByName('blobf')).SaveToStream(mem);                     mem.Position:=0;                     RichEdit1.Lines.LoadFromStream(mem);                     ADOQuery1.Next;                 end;         finally             mem.Free;         end;     end;         end.

     

    俺写的TTaskbarIcon,有了它,能轻松让你在任务栏给你的程序加个图标。         unit   UntTaskBarIcon;         interface         uses         SysUtils,   Classes,   ShellAPI,   Graphics,   Messages,   Menus,   Windows,   Forms,   Controls;         type         TMouseClickEvent   =   procedure   (Sender:TObject;IsRightButton:Boolean)   of   object;         TTaskBarIcon   =   class(TComponent)         private             FHint:   String;             FIcon:   TIcon;             FOnMouseClick:   TMouseClickEvent;             FPopupMenu:   TPopupMenu;             MyHandle:HWND;             FAutoAddIcon:   Boolean;             r:NOTIFYICONDATA;             FHasAddIcon:   Boolean;             FOnMouseDblClick:   TMouseClickEvent;             procedure   SetHint(const   Value:   String);             procedure   SetIcon(const   Value:   TIcon);             procedure   SetOnMouseClick(const   Value:   TMouseClickEvent);             procedure   SetPopupMenu(const   Value:   TPopupMenu);             procedure   SetAutoAddIcon(const   Value:   Boolean);             procedure   SetOnMouseDblClick(const   Value:   TMouseClickEvent);         protected             procedure   OnMessage(var   msg:TMessage);             procedure   MouseClick(IsRightButton:Boolean);             procedure   MouseDblClick(IsRightButton:Boolean);             procedure   Loaded;override;             function   ModifyIcon:Boolean;         public             property   HasAddIcon:Boolean   read   FHasAddIcon;             constructor   Create(AOwner:   TComponent);   override;             destructor   Destroy;   override;             procedure   Assign(Source:   TPersistent);override;             function   AddIcon:Boolean;             function   DeleteIcon:Boolean;             function   ChangeIcon(AIcon:TIcon;AHint:String):Boolean;         published             property   OnMouseClick:TMouseClickEvent   read   FOnMouseClick   write   SetOnMouseClick;             property   OnMouseDblClick:TMouseClickEvent   read   FOnMouseDblClick   write   SetOnMouseDblClick;             property   Icon:TIcon   read   FIcon   write   SetIcon;             property   Hint:String   read   FHint   write   SetHint;             property   PopupMenu:TPopupMenu   read   FPopupMenu   write   SetPopupMenu;             property   AutoAddIcon:Boolean   read   FAutoAddIcon   write   SetAutoAddIcon   default   True;         end;         procedure   Register;         implementation         procedure   Register;     begin         RegisterComponents('Samples',   [TTaskBarIcon]);     end;         {   TTaskBarIcon   }         function   TTaskBarIcon.AddIcon:Boolean;     begin         if   FHasAddIcon   then         begin             result:=False;             exit;         end;         r.cbSize:=sizeof(r);         r.Wnd:=MyHandle;         Randomize;         r.uID:=Random($FFFFFFFF);         r.uFlags:=NIF_ICON   or   NIF_MESSAGE   or   NIF_TIP;         r.uCallbackMessage:=   WM_USER+5;         if   FIcon.Empty   then             r.hIcon:=Application.Icon.Handle         else             r.hIcon:=FIcon.Handle;   {$warnings   off}           strcopy(r.szTip,PAnsiChar(FHint));         if   Shell_NotifyIcon(NIM_ADD,@r)   then   {$warnings   on}         begin             FHasAddIcon:=True;             result:=True;         end         else             result:=False;     end;         procedure   TTaskBarIcon.Assign(Source:   TPersistent);     begin         if   (Source<>nil)   and   (Source   Is   TTaskBarIcon)   then         begin             FIcon.Assign((Source   as   TTaskBarIcon).Icon);             FHint:=(Source   as   TTaskBarIcon).Hint;             ModifyIcon;         end         else             inherited   Assign(Source);     end;         constructor   TTaskBarIcon.Create(AOwner:   TComponent);     begin         inherited   Create(AOwner);         FIcon:=TIcon.Create;         FAutoAddIcon:=True;         FHasAddIcon:=False;         MyHandle:=   Classes.AllocateHWnd(OnMessage);     end;         function   TTaskBarIcon.DeleteIcon:Boolean;     begin         if   FHasAddIcon   then         begin   {$warnings   off}             result:=Shell_NotifyIcon(NIM_Delete,@r);   {$warnings   on}             if   result   then                 FHasAddIcon:=False;         end         else             result:=False;     end;         destructor   TTaskBarIcon.Destroy;     begin         if   FHasAddIcon   then             DeleteIcon;         FIcon.Free;         Classes.DeallocateHWnd(MyHandle);         inherited;     end;         procedure   TTaskBarIcon.Loaded;     begin         inherited;         if   (Not(csDesigning   in   ComponentState))   and   (FAutoAddIcon)   then             AddIcon;     end;         function   TTaskBarIcon.ModifyIcon:   Boolean;     begin         if   FHasAddIcon   then         begin         {$warnings   off}             StrCopy(r.szTip,PAnsiChar(FHint));   {$warnings   on}             if   FIcon.Empty   then                 r.hIcon:=Application.Icon.Handle             else                 r.hIcon:=FIcon.Handle;         {$warnings   off}             result:=Shell_NotifyIcon(NIM_MODIFY,@r);   {$warnings   on}         end         else             result:=False;     end;         function   TTaskBarIcon.ChangeIcon(AIcon:   TIcon;   AHint:string):   Boolean;     begin         if   Not(FHasAddIcon)   then             raise   Exception.Create('必须先AddIcon');         if   length(AHint)<=63   then             FHint:=AHint         else             raise   Exception.Create('Hint的长度不能超过63');         FIcon.Assign(AIcon);         result:=ModifyIcon;     end;         procedure   TTaskBarIcon.MouseClick(IsRightButton:   Boolean);     begin         if   FHasAddIcon   then         begin             if   (Assigned(FPopupMenu))   and   (FPopupMenu.AutoPopup)   then                 if   (FPopupMenu.TrackButton=tbLeftButton)   xor   (IsRightButton)   then                     FPopupMenu.Popup(Mouse.CursorPos.X,Mouse.CursorPos.Y);             if   Assigned(FOnMouseClick)   then                 FOnMouseClick(Self,IsRightButton);         end;     end;         procedure   TTaskBarIcon.MouseDblClick(IsRightButton:   Boolean);     begin         if   (FHasAddIcon)   and   (Assigned(FOnMouseDblClick))   then             FOnMouseDblClick(Self,IsRightButton);     end;         procedure   TTaskBarIcon.OnMessage(var   msg:   TMessage);     begin         if   msg.Msg<>WM_USER+5   then               msg.Result:=DefWindowProc(MyHandle,   msg.Msg,   msg.wParam,   msg.lParam)         else             case   msg.LParam   of                 WM_RBUTTONUP:   MouseClick(True);                 WM_LBUTTONUP:   MouseClick(False);                 WM_RBUTTONDBLCLK:   MouseDblClick(True);                 WM_LBUTTONDBLCLK:   MouseDblClick(False);             end;     end;         procedure   TTaskBarIcon.SetAutoAddIcon(const   Value:   Boolean);     begin         FAutoAddIcon   :=   Value;     end;         procedure   TTaskBarIcon.SetHint(const   Value:   String);     begin         if   length(Value)>63   then             raise   Exception.Create('Hint的长度不能超过64')         else         begin             FHint   :=   Value;             ModifyIcon;         end;     end;         procedure   TTaskBarIcon.SetIcon(const   Value:   TIcon);     begin         FIcon.Assign(Value);         ModifyIcon;     end;         procedure   TTaskBarIcon.SetOnMouseClick(const   Value:   TMouseClickEvent);     begin         FOnMouseClick   :=   Value;     end;         procedure   TTaskBarIcon.SetOnMouseDblClick(const   Value:   TMouseClickEvent);     begin         FOnMouseDblClick   :=   Value;     end;         procedure   TTaskBarIcon.SetPopupMenu(const   Value:   TPopupMenu);     begin         FPopupMenu   :=   Value;     end;         end.    

    Top126楼  old_bonze   (老和尚)   回复于 2004-09-08 18:22:53  得分 0

    unit   MD5;     //----------------------------------------------------------------------------     //   MD5算法单元.     //   作者:   old_bonze,   2004年7月26日     //   算法承袭自   RSA   Data   Security,   INC.   D5   Message-Digest   Algorithm   C语言版本.     //----------------------------------------------------------------------------     interface     uses         SysUtils,   Classes;         const         S11   =   7;         S12   =   12;         S13   =   17;         S14   =   22;         S21   =   5;         S22   =   9;         S23   =   14;         S24   =   20;         S31   =   4;         S32   =   11;         S33   =   16;         S34   =   23;         S41   =   6;         S42   =   10;         S43   =   15;         S44   =   21;                     CardinalSize   =   4;         type             MD5_CTX   =   record               State   :   packed   array   [   0..3   ]   of   Cardinal;               Count   :   packed   array   [   0..1   ]   of   Cardinal;               Buffer   :   packed   array   [   0..63   ]   of   char;         end;         PMD5_CTX   =   ^MD5_CTX;             PCardinal   =   ^Cardinal;         TPADDING   =   packed   array   [   0..63   ]   of   char;                 TMD5   =   class         private             class   procedure   MD5MemCopy(   Dest,   Src   :   PChar;   Cnt   :   Cardinal   );             class   procedure   MD5MemSet(   Dest   :   PChar;   Val   :   Byte;   Cnt   :   Cardinal   );             class   procedure   MD5Init(   context   :   PMD5_CTX   );             class   procedure   MD5Update(   context   :   PMD5_CTX;   Input   :   PChar;   InputLen   :   Cardinal   );             class   procedure   MD5Final(   Result   :   Pointer;   context   :   PMD5_CTX   );             class   procedure   MD5Transform(   state   :   PCardinal;   block   :   PChar   );             class   procedure   Encode(   output   :   PChar;   input   :   PCardinal;   len   :   Cardinal   );             class   procedure   Decode(   output   :   PCardinal;   input   :   PChar;   len   :   Cardinal   );             class   function   F(   x,y,z   :   Cardinal   )   :   Cardinal;             class   function   G(   x,y,z   :   Cardinal   )   :   Cardinal;             class   function   H(   x,y,z   :   Cardinal   )   :   Cardinal;             class   function   I(   x,y,z   :   Cardinal   )   :   Cardinal;                 class   procedure   FF(   var   a   :   Cardinal;   b,c,d,x,s,ac   :   Cardinal   );             class   procedure   GG(   var   a   :   Cardinal;   b,c,d,x,s,ac   :   Cardinal   );             class   procedure   HH(   var   a   :   Cardinal;   b,c,d,x,s,ac   :   Cardinal   );             class   procedure   II(   var   a   :   Cardinal;   b,c,d,x,s,ac   :   Cardinal   );                 class   function   ROTATE_LEFT(   a   :   Cardinal;   s   :   Cardinal   )   :   Cardinal;             class   function   PADDING   :   TPADDING;         public             class   procedure   MD5Value(   SrcStr   :   PChar;   SrcLen   :   Cardinal;   ResultPt   :   Pointer   );             class   function     MD5String(   SrcStr   :   PChar;   SrcLen   :   Cardinal   )   :   String;             class   function     FormatMD5Result(   ResultPT   :   Pointer   )   :   String;         end;                     var             PADDINGData   :   TPADDING;         Initted   :   boolean   =   false;         implementation         {   TMD5   }     class   function   TMD5.PADDING   :   TPADDING;     var         i   :   integer;     begin         if   not   initted   then   begin             PADDINGData[0]   :=   Chr($80);             for   i:=1   to   63   do   begin                   PADDINGData[i]   :=   Chr(0);             end;             initted   :=   true;         end;         result   :=   PADDINGData;     end;         class   function   TMD5.F(   x,y,z   :   Cardinal   )   :   Cardinal;     begin           result   :=   Cardinal(   (x   and   y)   or   (   (not   x)   and   z   )   );     end;             class   function   TMD5.G(   x,y,z   :   Cardinal   )   :   Cardinal;     begin           result   :=   Cardinal(   (x   and   z)   or   (   y   and   (not   z))   );     end;             class   function   TMD5.H(   x,y,z   :   Cardinal   )   :   Cardinal;     begin           result   :=   Cardinal(   x   xor   y   xor   z   );     end;             class   function   TMD5.I(   x,y,z   :   Cardinal   )   :   Cardinal;     begin           result   :=   Cardinal(   y   xor   (   x   or   (not   z)   )   );     end;             class   procedure   TMD5.FF(   var   a   :   Cardinal;   b,c,d,x,s,ac   :   Cardinal   );     begin           a   :=   a   +   F(b,c,d)   +   x   +   ac;           a   :=   ROTATE_LEFT(   a,   s   );           a   :=   a   +   b;     end;             class   procedure   TMD5.GG(   var   a   :   Cardinal;   b,c,d,x,s,ac   :   Cardinal   );     begin           a   :=   a   +   G(b,c,d)   +   x   +   ac;           a   :=   ROTATE_LEFT(   a,   s   );           a   :=   a   +   b;     end;             class   procedure   TMD5.HH(   var   a   :   Cardinal;   b,c,d,x,s,ac   :   Cardinal   );     begin           a   :=   a   +   H(b,c,d)   +   x   +   ac;           a   :=   ROTATE_LEFT(   a   ,   s   );           a   :=   a   +   b;     end;             class   procedure   TMD5.II(   var   a   :   Cardinal;   b,c,d,x,s,ac   :   Cardinal   );     begin           a   :=   a   +   I(b,c,d)   +   x   +   ac;           a   :=   ROTATE_LEFT(   a   ,   s   );           a   :=   a   +   b;     end;             class   function   TMD5.ROTATE_LEFT(   a   :   Cardinal;   s   :   Cardinal   )   :   Cardinal;     begin         result   :=   Cardinal(   (   a   shl   s   )   or   (   a   shr   (32-s))   );     end;         class   procedure   TMD5.Decode(output:   PCardinal;   input:   PChar;         len:   Cardinal);     var         j   :   Cardinal;     begin         j   :=   0;         while   j<len   do   begin             output^   :=   Cardinal(   Ord(input^)   );             input   :=   input   +   1;             output^   :=   output^   or   (   Cardinal(   Ord(input^)   )   shl   8   );             input   :=   input   +   1;             output^   :=   output^   or   (   Cardinal(   Ord(input^)   )   shl   16   );             input   :=   input   +   1;             output^   :=   output^   or   (   Cardinal(   Ord(input^)   )   shl   24   );             input   :=   input   +   1;             j   :=   j+4;             output   :=   PCardinal(   pchar(output)   +   CardinalSize   );         end;     end;         class   procedure   TMD5.Encode(output:   PChar;   input:   PCardinal;         len:   Cardinal);     var         j   :   Cardinal;     begin         j   :=   0;         while   j<len   do   begin             output^   :=   Chr(Byte(input^   and   $FF))   ;             output   :=   output   +   1;             output^   :=   Chr(Byte(   (   input^   shr   8   )   and   $FF   ))   ;             output   :=   output   +   1;             output^   :=   Chr(Byte(   (   input^   shr   16   )   and   $FF   ))   ;             output   :=   output   +   1;             output^   :=   Chr(Byte(   (   input^   shr   24   )   and   $FF   ))   ;             output   :=   output   +   1;             j   :=   j+4;             input   :=   PCardinal(   pchar(input)   +   CardinalSize   );         end;     end;         class   procedure   TMD5.MD5Final(Result:   Pointer;   context:   PMD5_CTX);     var         bits   :   packed   array   [0..7]   of   char;         index,   padLen   :   Cardinal;         pad   :   TPADDING;     begin         pad   :=   PADDING;         Encode(   @bits[0],   PCardinal(   @context^.Count[0]   ),8   );             index   :=   Cardinal(   (   context^.Count[0]   shr   3   )   and   $3F   );                 if   index   <   56   then               padLen   :=   56   -   index         else               padLen   :=   120   -   index;             MD5Update(   context,   @pad[0],   padLen   );         MD5Update(   context,   @bits[0],   8   );             Encode(   PChar(   Result   ),   PCardinal(   @context^.State[0]   ),   16   );         MD5MemSet(   PChar(   context   ),   0,   sizeof(   context^   )   );                 end;         class   procedure   TMD5.MD5Init(context:   PMD5_CTX);     begin         context^.State[0]   :=   $67452301;         context^.State[1]   :=   $efcdab89;         context^.State[2]   :=   $98badcfe;         context^.State[3]   :=   $10325476;         context^.Count[0]   :=   0;         context^.Count[1]   :=   0;     end;         class   procedure   TMD5.MD5MemCopy(Dest,   Src:   PChar;   Cnt:   Cardinal);     var         i   :   Cardinal;     begin         for   i:=0   to   Cnt-1   do   begin             Dest^   :=   Src^;             Dest   :=   Dest   +   1;             Src   :=   Src   +   1;         end;     end;         class   procedure   TMD5.MD5MemSet(Dest:   PChar;   Val:   Byte;   Cnt:   Cardinal);     var         i   :   Cardinal;     begin         for   i:=0   to   Cnt-1   do   begin               Dest^   :=     Chr(Val);               Dest   :=   Dest   +   1;         end;     end;      

    class   function   TMD5.MD5String(SrcStr:   PChar;   SrcLen:   Cardinal):   String;     var         rslt   :   packed   array   [   0..15   ]   of   Byte;     begin         MD5Value(   SrcStr,   SrcLen,   @rslt[0]   );         Result   :=   FormatMD5Result(   @rslt[0]   );     end;         class   procedure   TMD5.MD5Transform(state:   PCardinal;   block:   PChar);     var         a,b,c,d   :   Cardinal;         x   :   packed   array   [   0..15   ]   of   Cardinal;         p   :   PCardinal;     begin         p   :=   state;         a   :=   p^;         p   :=   PCardinal(   pchar(p)   +   CardinalSize   );         b   :=   p^;         p   :=   PCardinal(   pchar(p)   +   CardinalSize   );         c   :=   p^;         p   :=   PCardinal(   pchar(p)   +   CardinalSize   );         d   :=   p^;         Decode(   PCardinal(@x[0]),block,64   );                 FF   (a,   b,   c,   d,   x[   0],   S11,   $d76aa478);   {   1   }         FF   (d,   a,   b,   c,   x[   1],   S12,   $e8c7b756);   {   2   }         FF   (c,   d,   a,   b,   x[   2],   S13,   $242070db);   {   3   }         FF   (b,   c,   d,   a,   x[   3],   S14,   $c1bdceee);   {   4   }         FF   (a,   b,   c,   d,   x[   4],   S11,   $f57c0faf);   {   5   }         FF   (d,   a,   b,   c,   x[   5],   S12,   $4787c62a);   {   6   }         FF   (c,   d,   a,   b,   x[   6],   S13,   $a8304613);   {   7   }         FF   (b,   c,   d,   a,   x[   7],   S14,   $fd469501);   {   8   }         FF   (a,   b,   c,   d,   x[   8],   S11,   $698098d8);   {   9   }         FF   (d,   a,   b,   c,   x[   9],   S12,   $8b44f7af);   {   10   }         FF   (c,   d,   a,   b,   x[10],   S13,   $ffff5bb1);   {   11   }         FF   (b,   c,   d,   a,   x[11],   S14,   $895cd7be);   {   12   }         FF   (a,   b,   c,   d,   x[12],   S11,   $6b901122);   {   13   }         FF   (d,   a,   b,   c,   x[13],   S12,   $fd987193);   {   14   }         FF   (c,   d,   a,   b,   x[14],   S13,   $a679438e);   {   15   }         FF   (b,   c,   d,   a,   x[15],   S14,   $49b40821);   {   16   }             GG   (a,   b,   c,   d,   x[   1],   S21,   $f61e2562);   {   17   }         GG   (d,   a,   b,   c,   x[   6],   S22,   $c040b340);   {   18   }         GG   (c,   d,   a,   b,   x[11],   S23,   $265e5a51);   {   19   }         GG   (b,   c,   d,   a,   x[   0],   S24,   $e9b6c7aa);   {   20   }         GG   (a,   b,   c,   d,   x[   5],   S21,   $d62f105d);   {   21   }         GG   (d,   a,   b,   c,   x[10],   S22,     $2441453);   {   22   }         GG   (c,   d,   a,   b,   x[15],   S23,   $d8a1e681);   {   23   }         GG   (b,   c,   d,   a,   x[   4],   S24,   $e7d3fbc8);   {   24   }         GG   (a,   b,   c,   d,   x[   9],   S21,   $21e1cde6);   {   25   }         GG   (d,   a,   b,   c,   x[14],   S22,   $c33707d6);   {   26   }         GG   (c,   d,   a,   b,   x[   3],   S23,   $f4d50d87);   {   27   }         GG   (b,   c,   d,   a,   x[   8],   S24,   $455a14ed);   {   28   }         GG   (a,   b,   c,   d,   x[13],   S21,   $a9e3e905);   {   29   }         GG   (d,   a,   b,   c,   x[   2],   S22,   $fcefa3f8);   {   30   }         GG   (c,   d,   a,   b,   x[   7],   S23,   $676f02d9);   {   31   }         GG   (b,   c,   d,   a,   x[12],   S24,   $8d2a4c8a);   {   32   }             HH   (a,   b,   c,   d,   x[   5],   S31,   $fffa3942);   {   33   }         HH   (d,   a,   b,   c,   x[   8],   S32,   $8771f681);   {   34   }         HH   (c,   d,   a,   b,   x[11],   S33,   $6d9d6122);   {   35   }         HH   (b,   c,   d,   a,   x[14],   S34,   $fde5380c);   {   36   }         HH   (a,   b,   c,   d,   x[   1],   S31,   $a4beea44);   {   37   }         HH   (d,   a,   b,   c,   x[   4],   S32,   $4bdecfa9);   {   38   }         HH   (c,   d,   a,   b,   x[   7],   S33,   $f6bb4b60);   {   39   }         HH   (b,   c,   d,   a,   x[10],   S34,   $bebfbc70);   {   40   }         HH   (a,   b,   c,   d,   x[13],   S31,   $289b7ec6);   {   41   }         HH   (d,   a,   b,   c,   x[   0],   S32,   $eaa127fa);   {   42   }         HH   (c,   d,   a,   b,   x[   3],   S33,   $d4ef3085);   {   43   }         HH   (b,   c,   d,   a,   x[   6],   S34,     $4881d05);   {   44   }         HH   (a,   b,   c,   d,   x[   9],   S31,   $d9d4d039);   {   45   }         HH   (d,   a,   b,   c,   x[12],   S32,   $e6db99e5);   {   46   }         HH   (c,   d,   a,   b,   x[15],   S33,   $1fa27cf8);   {   47   }         HH   (b,   c,   d,   a,   x[   2],   S34,   $c4ac5665);   {   48   }             II   (a,   b,   c,   d,   x[   0],   S41,   $f4292244);   {   49   }         II   (d,   a,   b,   c,   x[   7],   S42,   $432aff97);   {   50   }         II   (c,   d,   a,   b,   x[14],   S43,   $ab9423a7);   {   51   }         II   (b,   c,   d,   a,   x[   5],   S44,   $fc93a039);   {   52   }         II   (a,   b,   c,   d,   x[12],   S41,   $655b59c3);   {   53   }         II   (d,   a,   b,   c,   x[   3],   S42,   $8f0ccc92);   {   54   }         II   (c,   d,   a,   b,   x[10],   S43,   $ffeff47d);   {   55   }         II   (b,   c,   d,   a,   x[   1],   S44,   $85845dd1);   {   56   }         II   (a,   b,   c,   d,   x[   8],   S41,   $6fa87e4f);   {   57   }         II   (d,   a,   b,   c,   x[15],   S42,   $fe2ce6e0);   {   58   }         II   (c,   d,   a,   b,   x[   6],   S43,   $a3014314);   {   59   }         II   (b,   c,   d,   a,   x[13],   S44,   $4e0811a1);   {   60   }         II   (a,   b,   c,   d,   x[   4],   S41,   $f7537e82);   {   61   }         II   (d,   a,   b,   c,   x[11],   S42,   $bd3af235);   {   62   }         II   (c,   d,   a,   b,   x[   2],   S43,   $2ad7d2bb);   {   63   }         II   (b,   c,   d,   a,   x[   9],   S44,   $eb86d391);   {   64   }             p   :=   state;         p^   :=   p^   +   a;         p   :=   PCardinal(   pchar(p)   +   CardinalSize   );         p^   :=   p^   +   b;         p   :=   PCardinal(   pchar(p)   +   CardinalSize   );         p^   :=   p^   +   c;         p   :=   PCardinal(   pchar(p)   +   CardinalSize   );         p^   :=   p^   +   d;         MD5MemSet(   pchar(   @x[0]   ),0,16*CardinalSize   );     end;         class   procedure   TMD5.MD5Update(context:   PMD5_CTX;   Input:   PChar;         InputLen:   Cardinal);     var         i,   index,   partLen   :   Cardinal;     begin         index   :=   Cardinal((   context^.Count[0]   shr   3   )   and   $3F   );             context^.Count[0]   :=   context^.Count[0]   +   (inputLen   shl   3);         if   context^.Count[0]   <   (   inputLen   shl   3   )   then               context^.Count[1]   :=   context^.Count[1]   +   1;         context^.Count[1]   :=   context^.Count[1]   +   (   inputLen   shr   29   );                       partLen   :=   64   -   index;                 if   InputLen   >=   partLen   then   begin               MD5MemCopy(   PChar(   @context^.Buffer[index]   ),   Input,   partLen   );               MD5Transform(   PCardinal(@context^.State[0]),   @context^.Buffer[0]   );                   i   :=   partLen;               while   i+63   <   inputLen   do   begin                   MD5Transform(   PCardinal(   @context^.State[0]   ),   Input   +   i   );                   i   :=   i   +   64;               end;                   index   :=   0;         end         else   begin               i   :=   0;         end;         if   inputLen   >   i   then               MD5MemCopy(   PChar(@context^.Buffer[index]),   Input+i,   InputLen-i   );     end;         class   procedure   TMD5.MD5Value(SrcStr:   PChar;   SrcLen:   Cardinal;         ResultPT:   Pointer);     var         context   :   MD5_CTX;     begin         MD5Init(   @context   );         MD5Update(   @context,   SrcStr,   SrcLen   );         MD5Final(   ResultPT,   @context   );     end;         class   function   TMD5.FormatMD5Result(ResultPT:   Pointer):   String;     var         rs   :   String;         p     :   pchar;         i   :   integer;     begin         rs   :=   '';         p   :=   pchar(ResultPT);         for   i:=0   to   15   do   begin               rs   :=   rs   +   Format('%.2x',   [Ord(p^)]);               p   :=   p   +   1;         end;         result   :=   lowercase(   rs   );     end;         end.    

     

     

    Top147楼  ksaiy   (阳光总在风雨后)   回复于 2004-10-24 00:12:36  得分 0

    unit   Crc32;         interface         uses   Windows;             const         Table:   array[0..255]   of   DWORD   =             ($00000000,   $77073096,   $EE0E612C,   $990951BA,             $076DC419,   $706AF48F,   $E963A535,   $9E6495A3,             $0EDB8832,   $79DCB8A4,   $E0D5E91E,   $97D2D988,             $09B64C2B,   $7EB17CBD,   $E7B82D07,   $90BF1D91,             $1DB71064,   $6AB020F2,   $F3B97148,   $84BE41DE,             $1ADAD47D,   $6DDDE4EB,   $F4D4B551,   $83D385C7,             $136C9856,   $646BA8C0,   $FD62F97A,   $8A65C9EC,             $14015C4F,   $63066CD9,   $FA0F3D63,   $8D080DF5,             $3B6E20C8,   $4C69105E,   $D56041E4,   $A2677172,             $3C03E4D1,   $4B04D447,   $D20D85FD,   $A50AB56B,             $35B5A8FA,   $42B2986C,   $DBBBC9D6,   $ACBCF940,             $32D86CE3,   $45DF5C75,   $DCD60DCF,   $ABD13D59,             $26D930AC,   $51DE003A,   $C8D75180,   $BFD06116,             $21B4F4B5,   $56B3C423,   $CFBA9599,   $B8BDA50F,             $2802B89E,   $5F058808,   $C60CD9B2,   $B10BE924,             $2F6F7C87,   $58684C11,   $C1611DAB,   $B6662D3D,             $76DC4190,   $01DB7106,   $98D220BC,   $EFD5102A,             $71B18589,   $06B6B51F,   $9FBFE4A5,   $E8B8D433,             $7807C9A2,   $0F00F934,   $9609A88E,   $E10E9818,             $7F6A0DBB,   $086D3D2D,   $91646C97,   $E6635C01,             $6B6B51F4,   $1C6C6162,   $856530D8,   $F262004E,             $6C0695ED,   $1B01A57B,   $8208F4C1,   $F50FC457,             $65B0D9C6,   $12B7E950,   $8BBEB8EA,   $FCB9887C,             $62DD1DDF,   $15DA2D49,   $8CD37CF3,   $FBD44C65,             $4DB26158,   $3AB551CE,   $A3BC0074,   $D4BB30E2,             $4ADFA541,   $3DD895D7,   $A4D1C46D,   $D3D6F4FB,             $4369E96A,   $346ED9FC,   $AD678846,   $DA60B8D0,             $44042D73,   $33031DE5,   $AA0A4C5F,   $DD0D7CC9,             $5005713C,   $270241AA,   $BE0B1010,   $C90C2086,             $5768B525,   $206F85B3,   $B966D409,   $CE61E49F,             $5EDEF90E,   $29D9C998,   $B0D09822,   $C7D7A8B4,             $59B33D17,   $2EB40D81,   $B7BD5C3B,   $C0BA6CAD,             $EDB88320,   $9ABFB3B6,   $03B6E20C,   $74B1D29A,             $EAD54739,   $9DD277AF,   $04DB2615,   $73DC1683,             $E3630B12,   $94643B84,   $0D6D6A3E,   $7A6A5AA8,             $E40ECF0B,   $9309FF9D,   $0A00AE27,   $7D079EB1,             $F00F9344,   $8708A3D2,   $1E01F268,   $6906C2FE,             $F762575D,   $806567CB,   $196C3671,   $6E6B06E7,             $FED41B76,   $89D32BE0,   $10DA7A5A,   $67DD4ACC,             $F9B9DF6F,   $8EBEEFF9,   $17B7BE43,   $60B08ED5,             $D6D6A3E8,   $A1D1937E,   $38D8C2C4,   $4FDFF252,             $D1BB67F1,   $A6BC5767,   $3FB506DD,   $48B2364B,             $D80D2BDA,   $AF0A1B4C,   $36034AF6,   $41047A60,             $DF60EFC3,   $A867DF55,   $316E8EEF,   $4669BE79,             $CB61B38C,   $BC66831A,   $256FD2A0,   $5268E236,             $CC0C7795,   $BB0B4703,   $220216B9,   $5505262F,             $C5BA3BBE,   $B2BD0B28,   $2BB45A92,   $5CB36A04,             $C2D7FFA7,   $B5D0CF31,   $2CD99E8B,   $5BDEAE1D,             $9B64C2B0,   $EC63F226,   $756AA39C,   $026D930A,             $9C0906A9,   $EB0E363F,   $72076785,   $05005713,             $95BF4A82,   $E2B87A14,   $7BB12BAE,   $0CB61B38,             $92D28E9B,   $E5D5BE0D,   $7CDCEFB7,   $0BDBDF21,             $86D3D2D4,   $F1D4E242,   $68DDB3F8,   $1FDA836E,             $81BE16CD,   $F6B9265B,   $6FB077E1,   $18B74777,             $88085AE6,   $FF0F6A70,   $66063BCA,   $11010B5C,             $8F659EFF,   $F862AE69,   $616BFFD3,   $166CCF45,             $A00AE278,   $D70DD2EE,   $4E048354,   $3903B3C2,             $A7672661,   $D06016F7,   $4969474D,   $3E6E77DB,             $AED16A4A,   $D9D65ADC,   $40DF0B66,   $37D83BF0,             $A9BCAE53,   $DEBB9EC5,   $47B2CF7F,   $30B5FFE9,             $BDBDF21C,   $CABAC28A,   $53B39330,   $24B4A3A6,             $BAD03605,   $CDD70693,   $54DE5729,   $23D967BF,             $B3667A2E,   $C4614AB8,   $5D681B02,   $2A6F2B94,             $B40BBE37,   $C30C8EA1,   $5A05DF1B,   $2D02EF8D);         procedure   CalcCRC32(FileName:   string;   var   CRC32:   DWORD);                 implementation         procedure   CalcCRC32(FileName:   string;   var   CRC32:   DWORD);     var         F:   file;         BytesRead:   DWORD;         Buffer:   array[1..65521]   of   Byte;         i:   Word;     begin         FileMode   :=   0;         CRC32         :=   $ffffffff;         {$I-}         AssignFile(F,   FileName);         Reset(F,   1);         if   IOResult   =   0   then         begin             repeat                     BlockRead(F,   Buffer,   SizeOf(Buffer),   BytesRead);                 for   i   :=   1   to   BytesRead   do                     CRC32   :=   (CRC32   shr   8)   xor   Table[Buffer[i]   xor   (CRC32   and   $000000FF)];             until   BytesRead   =   0;         end;         CloseFile(F);         {$I+}         CRC32   :=   not   CRC32;     end;         end.

     

    anti-Debug代码:     作者:ksaiy         unit   Anti;         interface         uses         Messages,Classes,   Windows,TlHelp32,SysUtils,Dialogs;         Function   SofticeLoaded:Boolean;     Procedure   Anti_DeDe();     Function   RegLoaded:Boolean;     Function   FileLoaded:Boolean;     Function   SoftIceXPLoaded:Boolean;     Function   IsBPX(addr:Pointer):Boolean;     Function   IsDebug():Boolean;         implementation              //Anti-Debug     Function   SoftIceLoaded:   Boolean;         //检测Win98下SoftICE     var         hFile:   Thandle;     Begin         Result   :=   false;         hFile   :=   CreateFileA('//./SICE',   GENERIC_READ   or   GENERIC_WRITE,             FILE_SHARE_READ   or   FILE_SHARE_WRITE,   nil,   OPEN_EXISTING,             FILE_ATTRIBUTE_NORMAL,   0);         if(   hFile   <>   INVALID_HANDLE_VALUE   )   then   begin             CloseHandle(hFile);             Result   :=   TRUE;         end;     End;         Function   SoftIceXPLoaded:Boolean;//检测Win2000/XP下的SoftIce     var         mark:Integer;         YesInt,NoInt:Integer;     begin         YesInt:=0;NoInt:=0;         mark:=0;         asm             push   offset   @handler             push   dword   ptr   fs:[0]             mov     dword   ptr   fs:[0],esp             xor     eax,eax             int   1             inc     eax             inc     eax             pop     dword   ptr   fs:[0]             add   esp,4             or       eax,eax             jz       @found             cmp   mark,   0             jnz       @found             jmp     @Nofound             @handler:                 mov   ebx,[esp+0ch]                 add   dword   ptr   [ebx+0b8h],02h                 mov   ebx,[esp+4]                 cmp   [ebx],   80000004h                 jz   @Table                 inc   mark             @Table:                 xor   eax,eax               ret             @found:                 mov   YesInt,1             @Nofound:                 mov   NoInt,1         end;         if   Yesint=1   then             Result:=True;         if   NoInt=1   then             Result:=False;     end;              //Anti-Monitor     Function   DumpLoaded:   Boolean;     //检测RegMON;     var         hFile:   Thandle;     Begin         Result:=   false;         hFile   :=   FindWindow(nil,'ProcDump32   (C)   1998,   1999,   2000   G-RoM,   Lorian   &   Stone');         if(   hFile   <>   0   )   then         begin             Result:=   TRUE;         end;     End;         Function   RegLoaded:   Boolean;     //检测RegMON;     var         hFile:   Thandle;     Begin         Result:=   false;         hFile   :=   FindWindow(nil,'Registry   Monitor   -   Sysinternals:   www.sysinternals.com');         if(   hFile   <>   0   )   then         begin             Result:=   TRUE;         end;     End;         Function   FileLoaded:   Boolean;     //检测FileMON;     var         hFile:   Thandle;     Begin         Result:=   false;         hFile   :=   FindWindow(nil,'File   Monitor   -   Sysinternals:   www.sysinternals.com');         if(   hFile   <>   0   )   then         begin             Result:=   TRUE;         end;     End;              //Anti-loader     Function   IsDebug():Boolean;   //检测调试器;     var         YInt,NInt:Integer;     begin         asm             mov   eax,fs:[30h]             movzx   eax,byte   ptr[eax+2h]             or   al,al             jz   @No             jnz   @Yes             @No:                 mov   NInt,1             @Yes:                 Mov   YInt,1         end;         if   YInt=1   then             Result:=True;         if   NInt=1   then             Result:=False;     end;              //DetectBreakpoint     Function   IsBPX(addr:Pointer):Boolean;//防范BPX断点     var         YInt,NInt:Integer;     begin         asm             mov   esi,addr             mov   al,[esi]             cmp   al,$CC             je   @Yes             jne   @No             @Yes:                 mov   YInt,1             @No:                 mov   NInt,1         end;         if   YInt=1   then             Result:=True;         if   NInt=1   then             Result:=False;     end;         Procedure   Anti_DeDe();//检测DEDE;     var         DeDeHandle:THandle;         i:integer;     begin         DeDeHandle:=FindWindow(nil,chr($64)+chr($65)+chr($64)+chr($65));         if   DeDeHandle<>0   then             begin                 For   i:=1   to   4500   do                     SendMessage(DeDeHandle,WM_CLOSE,0,0);             end;     end;         end.

    Top149楼  ksaiy   (阳光总在风雨后)   回复于 2004-10-24 00:14:29  得分 0

    procedure   TKenFrm.FormCreate(Sender:   TObject);     var         Reg:TRegistry;         RInt,SizeInt:Integer;         FileStr,UNStr,SNStr,RStr1,RStr2:String;         SumInt:Integer;         Str:String;         DllCrcStr,DllStr:String;         begin         Reg:=TRegistry.Create;         Reg.RootKey:=HKEY_LOCAL_MACHINE;         DllCrCStr:='E8A316E366BC9B7C';   //这个是加过壳的dll的CRC校验值,进行了Des加密.         DllStr:=ExtractFilePath(Application.ExeName)+'/Ken.dll';         if   ShlStr(FileCrc32(DllStr))<>ShlStr(KDD(DllCrCStr,'wwwksaiycom'))   then//校验dll失败后关闭计算机.     //         WinExit(EWX_SHUTDOWN   or   EWX_POWEROFF);//关机函数;调试的时候把这行注释掉,发布的时候激活此行。             ShowMessage('校验失败!');     {           在程序目录下提供了两个DLL文件,由于DLL进行了加壳那么在调试的时候就会出现问题,故提供一个加过壳的DLL和一个未     加过壳的DLL,怎么区分这两个DLL呢?文件大的那个是加过壳的,文件小的那个是未加过克的,调试的时候用文件小的那个DLL,     也就是把DLL名字改为Ken.dll,分布您的软件的时候请把大的那个DLL的名字改为Ken.dll一起随程序发布。         在上面对Ken.dll进行CRC校验,也就是说如果加壳的DLL被脱壳或替换,那么进行CRC校验不正确,这样就可以进行你要自己的     操作了,比如关闭计算机。         在这里我仅对DLL进行了校验,还没有对程序本上校验,不过方法是一样的,下面给出方法:     首先把自己的软件调试好以后,用FileCrc32取得主程序的CRC校验值,在对这个校验值进行加密,然后把密加结果存放到一个文     件里(这里我是举例说明,你也可以把它写到可执行文件里去,源码可以到我们的站点上下载),那么在文件的create事件里用     FileCrc32取得当前文件的CRC值,再把您存放在文件里的CRC值取出来解密后进行比较,如果正确那么就执行文件,如果不正确     就执行你自己的操作,比如关闭计算机。     这里我只是提供了方法,详细的模块我在我们的站点上有,但那是会员模块。您可以考虑成为我们的会员。具体可以参看我们的     网站上相关资料。     我们的网站:http://www.ksaiy.com     专业加密论坛:http://www.ksaiy.com/bbs     技术支持QQ:40188696   UC:934155     作者:ksaiy     }             Anti_DeDe();//检测DeDe;                 SumInt:=0;         Edit2.Text:=GetHDID;//取得系列号,每台计算机的系列号是唯一的;         //Anti-Debug;         if   IsSoftIce95Loaded   or   IsSoftIceNTLoaded   or   IsTRWLoaded   or   IsTRWLoaded   or   IsTRW2000Loaded   or   IsRegMONLoaded   or   IsFileMONLoaded   or   IsBW2000Loaded   then             begin                 PostMessage(Application.Handle,WM_CLOSE,0,0);//这里是指当发现调试工具的时候关闭程序本身,也可以设置为关闭计算机;             end;         //程序自校验;     //     RInt:=160000;//加壳后的文件大小,壳在压缩包里提供了FSG壳,这个文件的大小你可以加壳后来进行修改,然后在编译的你的软件再加壳就可以发布了;         //加壳方法:先打开FSG,然后选择你要加壳的文件即可。     //     FileStr:=ExpandFileName(ExtractFilePath(Application.ExeName)+'/Ken.exe');//这里写上自己的注册文件名;     //     if   Anti_Self(Rint,FileStr)=True   then     //         PostMessage(Application.Handle,WM_CLOSE,0,0);                 if   reg.OpenKey('/SoftWare/Microsoft/KEN',True)   then             begin                 RStr1:=Reg.ReadString('UN');                 RStr2:=Reg.ReadString('SN');             end;         reg.CloseKey;             if   (RStr1<>'')   and   (RStr2<>'')   then             begin                 UNStr:=KDD(RStr1,'shihongchun');                 SNStr:=KDD(RStr2,'shihongchun');                 if   ShlStr(SNStr)=ShlStr(RightStr(KXEN(Edit2.Text),20))   then     //进行非明码比较;                     begin                         //下面是注册成功你要做的事情,但千万不要出现"注册成功字样",你可以把某些功能给出来。                         Label1.Enabled:=False;                         Edit1.Enabled:=False;                         Button1.Enabled:=False;                     end                 else                     begin//对软件进行次数限制;                         if   Reg.OpenKey('/SoftWare/Microsoft/KEN',True)   then                                 Str:=Reg.ReadString('KENC');                             Reg.CloseKey;                         if   Str=''   then//判断次数是否为空,如果为空那么写入1;                             begin                                 if   Reg.OpenKey('/SoftWare/Microsoft/KEN',True)   then                                     Reg.WriteString('KENC','1919F0CF019DBB3E');   //1919F0CF019DBB3E是经过加密后的字符串,原值为1;                                 Reg.CloseKey;                             end                             else                             begin                             SumInt:=StrToInt(KDD(Str,'shihongchun'));   //读取次数                             SumInt:=SumInt+StrToInt(KDD('1919F0CF019DBB3E','shihongchun'));//对次数进行相加;                         if   SumInt>StrToInt(KDD('728DA73436100E6C','shihongchun'))   then     //判断次数是否等于30次;                             begin//下面可以设置次数到期限制一些功能;                                 MessageBox(KENFrm.Handle,'您好!软件的使用次数已到,请注册正式版!','注册提示',MB_OK+MB_ICONINFORMATION);                             end                         else                             begin//如果次数不到期,那么继续对次数的植进行相加;                                 if   Reg.OpenKey('/SoftWare/Microsoft/KEN',True)   then                                     Reg.WriteString('KENC',KED(IntToStr(SumInt),'shihongchun'));                                     Reg.CloseKey;                             end;                         end;                           end;             end         else             begin                 if   Reg.OpenKey('/SoftWare/Microsoft/KEN',True)   then                     Str:=Reg.ReadString('KENC');                     Reg.CloseKey;                 if   Str=''   then                     begin                         if   Reg.OpenKey('/SoftWare/Microsoft/KEN',True)   then                             Reg.WriteString('KENC','1919F0CF019DBB3E');                         Reg.CloseKey;                     end                     else                     begin                         SumInt:=StrToInt(KDD(Str,'shihongchun'));                         SumInt:=SumInt+StrToInt(KDD('1919F0CF019DBB3E','shihongchun'));                     if   SumInt>StrToInt(KDD('728DA73436100E6C','shihongchun'))   then                         begin                             MessageBox(KENFrm.Handle,'您好!软件的使用次数已到,请注册正式版!','注册提示',MB_OK+MB_ICONINFORMATION);                         end                     else                         begin                             if   Reg.OpenKey('/SoftWare/Microsoft/KEN',True)   then                                 Reg.WriteString('KENC',KED(IntToStr(SumInt),'shihongchun'));                             Reg.CloseKey;                         end;                     end;                 end;     end;         procedure   TKenFrm.Button1Click(Sender:   TObject);     var         Reg:TRegistry;     begin         Reg:=TRegistry.Create;         reg.RootKey:=HKEY_LOCAL_MACHINE;         if   Edit1.Text=''   then             MessageBox(KENFrm.handle,'用户名不能为空,请填写完整!','注册提示',MB_OK+MB_ICONINFORMATION)         else             begin                 if   Edit3.Text<>''   then                     begin                         if   reg.OpenKey('/SoftWare/Microsoft/KEN',True)   then                             begin                                 reg.WriteString('UN',KED(Edit1.Text,'shihongchun'));                                 reg.WriteString('SN',KED(Edit3.Text,'shihongchun'));                             end;                         reg.CloseKey;                         MessageBox(KENFrm.handle,'请重新启动程序来进行注册码校验!','注册提示',MB_OK+MB_ICONINFORMATION);                     end                 else                     MessageBox(KENFrm.handle,'注册码不能为空,请填写完整!','注册提示',MB_OK+MB_ICONINFORMATION)             end;         end;    

    Top150楼  metro   ()   回复于 2004-10-24 10:37:57  得分 0

    up!

    Top151楼  yuzhantao   (和女朋友一起去养狗)   回复于 2004-10-24 11:19:54  得分 0

    估计有不少人都不要意思把自己的拿出来吧     我也是,觉得没有什么是精彩的,怕人笑话,还是收藏吧

    Top152楼  ThenLong   (完美组合=Delphi/C++)   回复于 2004-10-24 11:27:56  得分 0

    //         WinExit(EWX_SHUTDOWN   or   EWX_POWEROFF);//关机函数;调试的时候把这行注释掉,发布的时候激活此行。         建议使用     {$IF   DEFINE   DEBUG}     ShowMessage('DEBUG');     {$else}     ShowMessage('NOT   DEBUG');     {$IFEND}

     

    {     ***************可以实现类似QQ窗体的隐藏效果*******************     }     {                                                 Design:     Kevin                      }         unit   QQForm;         interface         uses         Windows,   Messages,   SysUtils,   Classes,   Graphics,   Controls,   Forms,   Dialogs,   ExtCtrls,   Math;         {$R   QQfrm.res}         type         TQQForm   =   class(TComponent)         private             {   Private   declarations   }             fActive:Boolean;             fOldWndMethod:TWndMethod;             fForm:TForm;             ftimer:TTimer;             fAnchors:   TAnchors;         protected             {   Protected   declarations   }         public             {   Public   declarations   }             constructor   Create(AOwner:TComponent);   override;             destructor   Destroy;   override;             procedure   WndProc(var   Message:   TMessage);             procedure   WMMoving(var   Msg:   TMessage);             procedure   fOnTimer(Sender:   TObject);             function   FindParHWMD(Pos   :TPoint):THandle;         published             {   Published   declarations   }             property   Active:boolean     read   fActive     write   fActive;         end;         procedure   Register;         implementation         procedure   Register;     begin         RegisterComponents('Kevin',   [TQQForm]);     end;         {   TQQForm   }         constructor   TQQForm.Create(AOwner:   TComponent);     begin         inherited   Create(AOwner);         fActive:=True;         fTimer:=TTimer.Create(self);         fForm:=TForm(AOwner);         fForm.FormStyle   :=   fsStayOnTop;         fTimer.Enabled   :=   True;         fTimer.OnTimer   :=   fOnTimer;         fTimer.Interval   :=   200;         fOldWndMethod:=fForm.WindowProc;         fForm.WindowProc:=WndProc;     end;         destructor   TQQForm.Destroy;     begin         FreeAndNil(fTimer);         fForm.WindowProc:=fOldWndMethod;         inherited   Destroy;     end;         function   TQQForm.FindParHWMD(Pos:   TPoint):   THandle;     var         WControl   :TWinControl;     begin         WControl   :=   FindVCLWindow(Pos);         if   WControl   <>   nil   then         begin             while   not   (WControl.Parent   =   nil)   do             begin                 WControl   :=   WControl.Parent;             end;             Result   :=   WControl.Handle;         end   else   Result   :=   0;     end;         procedure   TQQForm.fOnTimer(Sender:   TObject);     const         coffset   =   3;     var         ParHandle   :THandle;     begin         ParHandle   :=   FindParHWMD(Mouse.CursorPos);         if   ParHandle   =   fForm.Handle   then         begin             if   akLeft   in   FAnchors   then   fForm.Left   :=   0;             if   akTop   in   FAnchors   then   fForm.Top   :=   0;             if   akRight   in   FAnchors   then   fForm.Left   :=   Screen.Width   -   fForm.Width;             if   akBottom   in   FAnchors   then   fForm.Top   :=   Screen.Height   -   fForm.Height;         end   else         begin             if   akLeft   in   FAnchors   then   fForm.Left   :=   -fForm.width   +   coffset;             if   akTop   in   FAnchors   then   fForm.Top   :=   -fForm.Height   +   coffset;             if   akRight   in   FAnchors   then   fForm.Left   :=   Screen.Width   -   coffset;             if   akBottom   in   FAnchors   then   fForm.Top   :=   Screen.Height   -   coffset;         end;     end;         procedure   TQQForm.WMMoving(var   Msg:   TMessage);     begin         inherited;         with   PRect(msg.LParam)^   do         begin             Left   :=   Min(Max(0,Left),Screen.Width   -   fForm.Width);             Top   :=   Min(Max(0,Top),Screen.Height   -   fForm.Height);             Right   :=   Min(Max(fForm.Width,Right),Screen.Width);             Bottom   :=   Min(Max(fForm.Height,Bottom),Screen.Height);                 FAnchors   :=   [];             if   Left   =   0   then   Include(FAnchors,akLeft);                 if   Right   =   Screen.Width   then   Include(FAnchors,akRight);                 if   (Top   =   0)   and   (Left   <>   0)   and   (Right   <>   Screen.Width)   then             begin                 Include(FAnchors,akTop);             end   else             if   Left   =   0   then             begin                 Include(FAnchors,akLeft);             end   else             if   Right   =   Screen.Width   then             begin                 Include(FAnchors,akRight);             end;                 if   Bottom   =   Screen.Height   then   Include(FAnchors,akBottom);                 fTimer.Enabled   :=   FAnchors   <>   [];         end;     end;         procedure   TQQForm.WndProc(var   Message:   TMessage);     begin         if   not   fActive   then         begin             fOldwndMethod(Message);             Exit;         end;           if   (CsDesigning   in   ComponentState)   then   fOldwndMethod(Message)         else             case   Message.Msg   of                   WM_MOVING   :   WMMoving(Message);             else   fOldwndMethod(Message);         end;     end;         end.    

     

    在Delphi中用拼音首字符序列来实现检索功能           作者:夏昆         教程来源:网络         点击数:14         更新时间:2004-11-10   【字体:小   大】         热                     在日常工作和生活中我们经常使用电子记事本查找个人通讯录信息,或在单位的应用程序中查询客户档案或业务资料,这个过程中往往需要输入大量的汉字信息,对于熟悉计算机的人这已经是一件头疼的事,那些不太熟悉计算机或根本不懂汉字输入的用户简直就望而生畏。作为对数据检索技术的一种新的尝试,作者探索使用汉字拼音的首字符序列作为检索关键字,这样,用户不必使用汉字,只须简单地键入要查询信息的每个汉字的拼音首字符即可。比如你想查找关键字“中国人民银行”,你只需要输入“zgrmyh”。作者希望通过下面的例子,为广大计算机同行起一个抛砖引玉的作用,让我们开发的程序更加便捷、好用。           ----   原理很简单,找出汉字表中拼音首字符分别为“A”至“Z”的汉字内码范围,这样,对于要检索的汉字只需要检查它的内码位于哪一个首字符的范围内,就可以判断出它的拼音首字符。           ----   程序更简单,包括3个控件:一个列表存放着所有待检索的信息;一个列表用于存放检索后的信息;一个编辑框用于输入检索关键字(即拼音首字符序列)。详细如下:           ----   1.进入Delphi创建一个新工程:Project1           ----   2.在Form1上创建以下控件并填写属性:           控件类型             属性名称     属性值     Edit                       Name             Search     ListBox                 Name             SourceList     Items             输入一些字符串,如姓名等,用于提供检索数据     ListBox                 Name             ResultList               ----   3.键入以下两个函数           //   获取指定汉字的拼音索引字母,如:“汉”的索引字母是“H”     function   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;         //   在指定的字符串列表SourceStrs中检索符合拼音索引字符串     PYIndexStr的所有字符串,并返回。     function   SearchByPYIndexStr     (   SourceStrs:TStrings;       PYIndexStr:string):string;     label   NotFound;     var         i,   j       :integer;         hzchar   :string;     begin         for   i:=0   to   SourceStrs.Count-1   do             begin                 for   j:=1   to   Length(PYIndexStr)   do                     begin                         hzchar:=SourceStrs[i][2*j-1]       +   SourceStrs[i][2*j];                         if   (PYIndexStr[j]<>'?')   and       (UpperCase(PYIndexStr[j])   <>       GetPYIndexChar(hzchar))   then   goto   NotFound;                     end;                 if   result=''   then   result   :=   SourceStrs[i]                 else   result   :=   result   +   Char     (13)   +   SourceStrs[i];     NotFound:             end;     end;         4.增加编辑框Search的OnChange事件:     procedure   TForm1.SearchChange(Sender:   TObject);     var   ResultStr:string;     begin         ResultStr:='';         ResultList.Items.Text   :=   SearchByPYIndexStr     (Sourcelist.Items,   Search.Text);     end;                 ----   5.编译运行后,在编辑框Search中输入要查询字符串的拼音首字符序列,检索结果列表ResultList就会列出检索到的信息,检索中还支持“?”通配符,对于难以确定的的文字使用“?”替代位置,可以实现更复杂的检索。          

     

    我这有个关于注册嘛的,直接读取硬盘号,然后生成注册码     不过我试验过,有些机器无效,不知道为什么?     不过一定要用'DiskID.dll',需要的话可以找我,Email:WINBOY8119@HOTMAIL.COM     /     unit   C_password;         interface         uses         Windows,   Messages,dateutils,   SysUtils,   Variants,   Classes,   Graphics,   Controls,   Forms,         Dialogs,   DB,c_main,   DBTables,   ComCtrls,   StdCtrls,   jpeg,   ExtCtrls,   DosMove;         type         DRIVER_INFO_OK   =   record         ModalNumber   :   array[0..39]   of   char;         SerialNumber   :   array   [0..19]   of   char;         ControlNum   :   array[0..7]of   char;         DriveType   :   dword;         Cylinders   :   dword;         Heads   :   dword;         Sectors   :   dword;         end;             Tpasswordform   =   class(TForm)             Image1:   TImage;             Label2:   TLabel;             Label1:   TLabel;             Label5:   TLabel;             Label6:   TLabel;             Label7:   TLabel;             Label3:   TLabel;             Label4:   TLabel;             BtnCancel:   TButton;             Emjh:   TEdit;             BtnOK:   TButton;             EKL:   TEdit;             StatusBar1:   TStatusBar;             Button1:   TButton;             Button2:   TButton;             DosMove1:   TDosMove;             tblpassword:   TTable;             tblzc:   TTable;             tblzcD_ZCH:   TStringField;             tblzcD_ZCM:   TStringField;             procedure   BtnOKClick(Sender:   TObject);             procedure   BtnCancelClick(Sender:   TObject);             procedure   FormShow(Sender:   TObject);             procedure   Button1Click(Sender:   TObject);             procedure   Button2Click(Sender:   TObject);         private             {   Private   declarations   }         public             {   Public   declarations   }         end;         function   IsWinNT:boolean;                     stdcall;   external   'DiskID.dll'                     name   'IsWinNT';     function   ReadPhysicalDrive(driveID:integer;buffer:Pointer;bufLen:integer):integer;                     stdcall;   external   'DiskID.dll'                     name   'ReadPhysicalDriveInNT';     function   ReadPhysicalDrive9X(driveID:integer;buffer:Pointer;bufLen:integer):integer;                     stdcall;   external   'DiskID.dll'                     name   'ReadDrivePortsInWin9X';     function   getHardDriveComputerID:int64;                     stdcall;   external   'DiskID.dll'                     name   'getHardDriveComputerID';             var         passwordform:   Tpasswordform;         ThreeTime   :   integer;         pppsss   :   int64;         queding   :   int64;         DD   :   TdateTime;         implementation                 {$R   *.dfm}     procedure   Tpasswordform.Button1Click(Sender:   TObject);     var         x:DRIVER_INFO_OK;             ttpp   :   string;     begin     ///生成注册码         if   IsWinNT   then             ReadPhysicalDrive(0,@x,256)         else             ReadPhysicalDrive9X(0,@x,256);             emjh.Text   :=   (x.SerialNumber);         emjh.Text   :=   (x.ModalNumber);         emjh.Text   :=   (x.ControlNum)   ;           emjh.Text   :=   inttostr(getHardDriveComputerID);     /生成注册号//下面这段是算法,我是将硬盘号+电话号码8889155+当天日期     pppsss   :=   DaysBetween(strTodatetime(formatdatetime('yyyy',date)+'-1-1'),date);     pppsss   :=   pppsss+   strToint64(trim(emjh.Text));     pppsss   :=   pppsss   +   8889155;     queding   :=   (pppsss);     end;

    //====================================     //code   by   yh     //   设置所有控件的只读属性     //   set_value   :为   控件的只读属性   的值     //form   :   要的设置的窗体     //====================================         function   set_read(form:Tform;set_value:   boolean):   boolean;     var         i:integer;     begin           if   form=   nil   then   form:=tform.Create(nil);           for   i:=0   to   form.ComponentCount-1   do               begin                   if   (form.Components[i].ClassName='TbsSkinDBEdit')     then                       TbsSkinDBEdit(form.Components[i]).ReadOnly:=set_value;               end;     end;    

     

    mdi主窗体打开子窗体     procedure   Tmain_form.OpenForm(FormClass:   TFormClass;   var   fm;   AOwner:TComponent);     var         i:   integer;         Child:TForm;     begin         for   i   :=   0   to   Screen.FormCount   -1   do                 if   Screen.Forms[i].ClassType=FormClass   then                 begin                     Child:=Screen.Forms[i];                     if   Child.WindowState=wsMinimized   then                           ShowWindow(Child.handle,SW_SHOWNORMAL)                     else                           ShowWindow(Child.handle,SW_SHOWNA);                     if   (not   Child.Visible)   then   Child.Visible:=True;                     Child.BringToFront;                     Child.Setfocus;                     TForm(fm):=Child;                     exit;                 end;         Child:=TForm(FormClass.NewInstance);         TForm(fm):=Child;         Child.Create(AOwner);       //   showmessage(inttostr(Screen.FormCount))   ;       //   if     Screen.FormCount=4   then           //Main_form.ToolButton6.Click;             end;    

     

    //最好用的人民币金额大小写转换函数         Function   NtoC(   n0   :Extended)   :wideString;     Function   IIF(b   :boolean;   s1,s2   :string):string;     begin     {本函数在VFP和VB里均为内部函数}     if   b   then   IIF:=s1   else   IIF:=s2;     end;     Const   c:WideString   =   '零壹贰叁肆伍陆柒捌玖◇分角元拾佰仟万拾佰仟亿拾佰仟万';     var   L,i,n   :integer;     Z,a   :boolean;     s,   st   :WideString;     begin     s:=   FormatFloat('0',n0*100);     L:=   Length(s);     Z:=   false;     For   i:=1   to   L   do     begin     n:=   ord(   s[L-i+1])-48;//   StrToInt(   s[L-i+1]);     a:=   (i=11)or(i=7)or(i=3)or(i=1);                 //亿、万、元、分位     st:=IIF((n=0)and(Z   or   a),'',   c[n+1])       //数值     +   IIF((n=0)and(i=1),'整',                           //分位为零     IIF((n>0)or   a,   c[i+11],''))                 //单位     +   IIF((n=0)and(not   Z)and(i>1)and   a,'零','')     //亿、万、元位为零而千万、千、角位不为零     +   st;     Z:=   n=0;     end;     For   i:=1   To   Length(st)   do     If   Copy(st,i,2)='亿万'   Then   Delete(st,i+1,1);     //亿位和万位之间都是零时会出现’亿万’     result:=   IIF(n0>9999999999999.99,'溢出',   IIf(n0   =   0,     '零',   st));     End;  

       

    这里太多了:         关于tClientDataSet       http://www.01cn.net/cgi-bin/topic_show.cgi?id=160&h=1&bpg=2&age=0       什么是O/R   Mapping,为什么要O/R   Mapping       http://www.01cn.net/cgi-bin/topic_show.cgi?id=1068&h=1&bpg=2&age=0       程序关闭的时候更改程序自身的扩展名       http://www.01cn.net/cgi-bin/topic_show.cgi?id=14&h=1&bpg=3&age=0       有关   PE   文件内部结构的问题       http://www.01cn.net/cgi-bin/topic_show.cgi?id=179&h=1&bpg=3&age=0       任务的多线程分解       http://www.01cn.net/cgi-bin/topic_show.cgi?id=301&h=1&bpg=3&age=0       我写的的一个线程类       http://www.01cn.net/cgi-bin/topic_show.cgi?id=275&h=1&bpg=2&age=0       如何再调试的时候看内存地址       http://www.01cn.net/cgi-bin/topic_show.cgi?id=441&h=1&bpg=2&age=0       有什么方法可以看看DLL里面的内容!!       http://www.01cn.net/cgi-bin/topic_show.cgi?id=733&h=1&bpg=2&age=0       HooK模块进入了进程,却不执行代码.   为什么?       http://www.01cn.net/cgi-bin/topic_show.cgi?id=759&h=1&bpg=2&age=0       VirtualAllocEx出错,怎么解决?       http://www.01cn.net/cgi-bin/topic_show.cgi?id=758&h=1&bpg=2&age=0       Delphi程序如何与Flash文件通讯?       http://www.01cn.net/cgi-bin/topic_show.cgi?id=778&h=1&bpg=2&age=0       用多线程实现电梯调度。请大家帮帮忙。       http://www.01cn.net/cgi-bin/topic_show.cgi?id=81&h=1&bpg=2&age=0       引入表式的API   HOOK如何HOOK加壳程序?       http://www.01cn.net/cgi-bin/topic_show.cgi?id=984&h=1&bpg=2&age=0       进程隐藏的C代码翻译成DELPHI遇到困难?       http://www.01cn.net/cgi-bin/topic_show.cgi?id=1010&h=1&bpg=2&age=0       ]   关于调用DLL中的窗体的问题。   1   2       http://www.01cn.net/cgi-bin/topic_show.cgi?id=825&h=1&bpg=1&age=0       在WIN2000下用exitwindowsex()关机没用       http://www.01cn.net/cgi-bin/topic_show.cgi?id=1086&h=1&bpg=1&age=0       为啥用sendmessag在程序最小化后收不到消息?       http://www.01cn.net/cgi-bin/topic_show.cgi?id=1163&h=1&bpg=1&age=0       再问,关于HOOK里转换键盘按键的问题       http://www.01cn.net/cgi-bin/topic_show.cgi?id=789&h=1&bpg=1&age=0       哪位有内存修改器的源代码吗       http://www.01cn.net/cgi-bin/topic_show.cgi?id=779&h=1&bpg=1&age=0       再问一个DLL中form的问题。       http://www.01cn.net/cgi-bin/topic_show.cgi?id=1297&h=1&bpg=1&age=0       偶写的类似注册表的组件       http://www.01cn.net/cgi-bin/topic_show.cgi?id=1009&h=1&bpg=1&age=0       泛型编程在Delphi中的实现之大辩论(精彩!)       http://www.01cn.net/cgi-bin/topic_show.cgi?id=67&h=1&bpg=1&age=0       最经典的视觉欺骗       http://www.01cn.net/cgi-bin/topic_show.cgi?id=193&h=1&bpg=1&age=0       编写VFW编码器(Delphi)       http://www.01cn.net/cgi-bin/topic_show.cgi?id=211&h=1&bpg=1&age=0       多个位图合并到一个文件       http://www.01cn.net/cgi-bin/topic_show.cgi?id=302&h=1&bpg=1&age=0       MediaPlayer如何调节音量?在大富翁发贴好久了没有应!       http://www.01cn.net/cgi-bin/topic_show.cgi?id=311&h=1&bpg=1&age=0       Flash播放器源码分析       http://www.01cn.net/cgi-bin/topic_show.cgi?id=210&h=1&bpg=1&age=0       边界   dot   点点的画出       http://www.01cn.net/cgi-bin/topic_show.cgi?id=1029&h=1&bpg=1&age=0       Fastlib   的   Demo   程序修正       http://www.01cn.net/cgi-bin/topic_show.cgi?id=1064&h=1&bpg=1&age=0       利用   GDI+   打开不同类型格式的图片(含头文件和示例)       http://www.01cn.net/cgi-bin/topic_show.cgi?id=1091&h=1&bpg=1&age=0       发布一个模拟   DirectX   绘图方法的无闪烁绘图控件       http://www.01cn.net/cgi-bin/topic_show.cgi?id=1083&h=1&bpg=1&age=0       MediaPlayer9   ActiveX   使用初探       http://www.01cn.net/cgi-bin/topic_show.cgi?id=1318&h=1&bpg=1&age=0       李维的《inside   vcl》菜鸟该咋看?       http://www.01cn.net/cgi-bin/topic_show.cgi?id=369&h=1&bpg=1&age=0       delpin的编程是面向那方面的?       http://www.01cn.net/cgi-bin/topic_show.cgi?id=1396&h=1&bpg=1&age=0       菜鸟的DELPHI之路   1   2       http://www.01cn.net/cgi-bin/topic_show.cgi?id=722&h=1&bpg=1&age=0       连接SQLSERVER的一些小小经验       http://www.01cn.net/cgi-bin/topic_show.cgi?id=838&h=1&bpg=1&age=0       如何使程序在运行时自动注册ActiveX控件       http://www.01cn.net/cgi-bin/topic_show.cgi?id=532&h=1&bpg=1&age=0       Delphi   的RTTI机制浅探(续)       http://www.01cn.net/cgi-bin/topic_show.cgi?id=486&h=1&bpg=1&age=0       Delphi   Open   Tools   API   浅探       http://www.01cn.net/cgi-bin/topic_show.cgi?id=487&h=1&bpg=1&age=0       Delphi   的持续机制浅探       http://www.01cn.net/cgi-bin/topic_show.cgi?id=488&h=1&bpg=1&age=0       Delphi   的消息机制浅探       http://www.01cn.net/cgi-bin/topic_show.cgi?id=489&h=1&bpg=1&age=0       Delphi的对象机制浅探       http://www.01cn.net/cgi-bin/topic_show.cgi?id=490&h=1&bpg=1&age=0       DELPHI中DBGrid中行的定位及着色实现       http://www.01cn.net/cgi-bin/topic_show.cgi?id=653&h=1&bpg=1&age=0       Delphi   的RTTI机制浅探       http://www.01cn.net/cgi-bin/topic_show.cgi?id=485&h=1&bpg=1&age=0       来来来~发个招骂贴:我和Soul的无聊讨论……       http://www.01cn.net/cgi-bin/topic_show.cgi?id=543&h=1&bpg=1&age=0       有关RAVE的常见问题及解决方法,欢迎大家讨论       http://www.01cn.net/cgi-bin/topic_show.cgi?id=659&h=1&bpg=1&age=0       为什么Delphi的好书这么少?       http://www.01cn.net/cgi-bin/topic_show.cgi?id=1364&h=1&bpg=1&age=0       Delphi   的接口机制浅探       http://www.01cn.net/cgi-bin/topic_show.cgi?id=528&h=1&bpg=1&age=0    

    procedure   TFrmBase.DoControl(WinControl:   TWinControl;                                                                         Shift:   TShiftState;   X,   Y,   Precision:   integer);     var     SC_MANIPULATE:   Word;     H,W:Integer   ;     begin         H   :=   WinControl.Height   -   5   ;         W   :=   WinControl.Width   -   5   ;         //¹â±êÔڿؼþµÄ×î×ó²à         if   (X   <=   Precision)   and   (Y   >   Precision)   and   (Y   <   H   -   Precision)then         begin             SC_MANIPULATE   :=   $F001;             WinControl.Cursor   :=   crSizeWE;         end           //¹â±êÔڿؼþµÄ×îÓҲࠠ       else   if   (X   >=   W   -   Precision)   and   (Y   >   Precision)   and   (Y   <   H   -   Precision)   then         begin             SC_MANIPULATE   :=   $F002;             WinControl.Cursor   :=   crSizeWE;         end           //¹â±êÔڿؼþµÄ×îÉϲࠠ       else   if   (X   >   Precision)   and   (X   <   W   -   Precision)   and   (Y   <=   Precision)   then         begin             SC_MANIPULATE   :=   $F003;             WinControl.Cursor   :=   crSizeNS;         end         //¹â±êÔڿؼþµÄ×óÉϽǠ        else   if   (X   <=   Precision)   and   (Y   <=   Precision)   then         begin             SC_MANIPULATE   :=   $F004;             WinControl.Cursor   :=   crSizeNWSE;         end         //¹â±êÔڿؼþµÄÓÒÉϽǠ        else   if   (X   >=   W   -Precision)   and   (Y   <=   Precision)   then         begin             SC_MANIPULATE   :=   $F005;             WinControl.Cursor   :=   crSizeNESW     ;         end         //¹â±êÔڿؼþµÄ×îϲࠠ       else   if   (X   >   Precision)   and   (X   <   W   -   Precision)   and   (Y   >=   H   -   Precision)   then         begin             SC_MANIPULATE   :=   $F006;             WinControl.Cursor   :=   crSizeNS;         end         //¹â±êÔڿؼþµÄ×óϽǠ        else   if   (X   <=   Precision)   and   (Y   >=   H   -   Precision)   then         begin             SC_MANIPULATE   :=   $F007;             WinControl.Cursor   :=   crSizeNESW;         end         //¹â±êÔڿؼþµÄÓÒϽǠ        else   if   (X   >=   W   -   Precision)     and     (Y   >=   H   -   Precision)   then         begin             SC_MANIPULATE   :=   $F008;             WinControl.Cursor   :=   crSizeNWSE;         end         //¹â±êÔڿؼþµÄ¿Í»§Çø£¨Òƶ¯Õû¸ö¿Ø¼þ£©         else   if   (X   >   Precision)   and   (Y   >   Precision)   and   (X   <   W-Precision)   and   (Y   <   H-Precision)then         begin             SC_MANIPULATE   :=   $F009;             WinControl.Cursor   :=   crSizeAll;         end         else         begin             SC_MANIPULATE   :=   $F000;             WinControl.Cursor   :=   crDefault;         end;         if   Shift   =   [ssLeft]   then         begin             ReleaseCapture;             WinControl.Perform(WM_SYSCOMMAND,   SC_MANIPULATE,   0);         end;     end;

    Top

    unit   sFiles;         interface         uses   Windows,   SysUtils,   Classes,   Registry,   ShellAPI,   SHFolder;         function   ThrowFiles(const   FileNames:   String;   Confirm:   Boolean   =   true;         bProbar:   Boolean   =   true):   Boolean;   overload;//将文件扔到回收站     {     可以这样调用,以指定多个文件:         ThrowFiles('a.txt'+#0+'b.txt'+#0+'c.txt'+#0,   false,   false);         每个文件名后必须跟#0或者使用PChar类型:         PChar('a.txt')   +   PChar('b.txt')...         如果觉得不方便,   可以使用下面定义的另一个版本的这个函数,         但在执行效率上可能有损失,   特别是文件比较多的时候     }     function   ThrowFiles(const   FileNames:   array   of   String;   Confirm:   Boolean   =   true;         bProbar:   Boolean   =   true):   Boolean;   overload;//将文件扔到回收站         //判断是否有效的win32可执行文件(exe,   dll,   cpl等)     function   IsWin32PEFile(const   FileName:   string):   Boolean;         implementation             function   ThrowFiles(const   FileNames:   array   of   String;   Confirm:   Boolean   =   true;         bProbar:   Boolean   =   true):   Boolean;   overload;     var         T:   TSHFileOpStruct;         i:   Integer;         s:   String;     begin         Result   :=   true;         s   :=   '';         FillChar(T,   SizeOf(T),   0);         with   T   do         begin             Wnd   :=   0;             wFunc   :=   FO_DELETE;             fFlags   :=   FOF_ALLOWUNDO;             if   not   Confirm   then                 fFlags   :=   fFlags   or   FOF_NOCONFIRMATION;             if   not   bProbar   then                 fFlags   :=   fFlags   or   FOF_SILENT;             for   i:=0   to   Length(FileNames)-1   do             begin                 s   :=   s   +   FileNames[i]   +   #0;             end;             pFrom   :=   PChar(s);         end;         if   SHFileOperation(T)   <>   0   then             Result   :=   false;     end;             function   ThrowFiles(const   FileNames:   String;   Confirm:   Boolean   =   true;         bProbar:   Boolean   =   true):   Boolean;   overload;     var         T:   TSHFileOpStruct;     begin         Result   :=   true;         FillChar(T,   SizeOf(T),   0);         with   T   do         begin             Wnd   :=   0;             wFunc   :=   FO_DELETE;             fFlags   :=   FOF_ALLOWUNDO;             if   not   Confirm   then                 fFlags   :=   fFlags   or   FOF_NOCONFIRMATION;             if   not   bProbar   then                 fFlags   :=   fFlags   or   FOF_SILENT;         end;         T.pFrom   :=   PChar(FileNames);         if   SHFileOperation(T)   <>   0   then             Result   :=   false;     end;         function   IsWin32PEFile(const   FileName:   string):   Boolean;     var         hFile:   THandle;         idh:   TImageDosHeader;         inh:   TImageNTHeaders;     begin         Result   :=   false;             //open   an   existing   file         hFile   :=   FileOpen(FileName,   fmOpenRead   or   fmShareDenyWrite);         if   hFile   =   INVALID_HANDLE_VALUE   then         begin             raise   Exception.CreateFmt('Cannot   open   %s:   %s',   [FileName,                 SysErrorMessage(GetLastError)]);             exit;         end;             //read   image   dos   header   to   idh         FileRead(hFile,   idh,   SizeOf(idh));         if   idh.e_magic   =   IMAGE_DOS_SIGNATURE   then   //if   'MZ'   flag   was   detected         begin             FileSeek(hFile,   idh._lfanew,   FILE_BEGIN);   //重定位到image   nt   headers             FileRead(hFile,   inh,   SizeOf(inh));   //得到这个结构             if   inh.Signature   =   IMAGE_NT_SIGNATURE   then   //判断标志位                 Result   :=   true;         end;         FileClose(hFile);     end;         initialization         Randomize;     end.         ----------     这些函数只是我整理的文件操作工具箱中的一部分,所有最后的initialization         Randomize;     如果程序中没用到random函数   可以不必写

     

    unit   sInternet;         interface         uses   Windows,   WinSock,   SysUtils,   WinInet,   Dialogs;         function   IsOnline:   Boolean;     //检测本机是否在线     function   IsOffline:   Boolean;   //检测本机是否不在线上,与上一个函数值刚好相反,用哪个看个人爱好         function   IsUseModem:   Boolean;   //是否使用调制解调器连接到网络     function   IsUseLAN:   Boolean;     //是否使用局域网连接到网络     function   IsUseProxy   :   Boolean;   //是否通过代理服务器连接到网络     function   ModemIsBusy:   Boolean;   //调制解调器是否繁忙     function   RasIsInstalled:   Boolean;   //Ras是否已经安装         function   GetIPAddress:   string;   //获取本机IP地址         implementation         const         INTERNET_CONNECTION_MODEM             =   $00000001;         INTERNET_CONNECTION_LAN                 =   $00000010;         INTERNET_CONNECTION_PROXY             =   $00000100;         INTERNET_CONNECTION_MODEM_BUSY   =   $00001000;         INTERNET_RAS_INSTALLED                   =   $00010000;         INTERNET_CONNECTION_OFFLINE         =   $00100000;         function   IsOnline:   Boolean;     begin         Result   :=   InternetGetConnectedState(nil,   0);     end;         function   IsOffline:   Boolean;     begin         Result   :=   not   InternetGetConnectedState(nil,   0);     end;         function   IsUseModem:   Boolean;   //是否使用调制解调器连接到网络     var         dFlag:   Dword;     begin         Result   :=   false;         InternetGetConnectedState(@dFlag,   0);         if   (dFlag   and   INTERNET_CONNECTION_MODEM)>0   then             Result   :=   true;     end;         function   IsUseLAN:   Boolean;     //是否使用局域网连接到网络     var         dFlag:   Dword;     begin         Result   :=   false;         InternetGetConnectedState(@dFlag,   0);         if   (dFlag   and   INTERNET_CONNECTION_LAN)>0   then             Result   :=   true;     end;         function   IsUseProxy   :   Boolean;   //是否通过代理服务器连接到网络     var         dFlag:   Dword;     begin         Result   :=   false;         InternetGetConnectedState(@dFlag,   0);         if   (dFlag   and   INTERNET_CONNECTION_PROXY)>0   then             Result   :=   true;     end;         function   ModemIsBusy:   Boolean;   //调制解调器是否繁忙     var         dFlag:   Dword;     begin         Result   :=   false;         InternetGetConnectedState(@dFlag,   0);         if   (dFlag   and   INTERNET_CONNECTION_MODEM_BUSY)>0   then             Result   :=   true;     end;         function   RasIsInstalled:   Boolean;   //Ras是否已经安装     var         dFlag:   Dword;     begin         Result   :=   false;         InternetGetConnectedState(@dFlag,   0);         if   (dFlag   and   INTERNET_RAS_INSTALLED)>0   then             Result   :=   true;     end;         function   GetIPAddress:   string;     var         wVersionRequested:   Word;         wsaData:   TWSAData;         sName:   array[0..127]   of   char;         p:   PHostEnt;         p2:   PChar;         i:   Integer;     begin         try             wVersionRequested   :=   MakeWord(1,   1);             i   :=   WSAStartup(wVersionRequested,   wsaData);             if   i   <>   0   then             begin                 Result   :=   '';                 exit;             end;             GetHostName(@sName,   128);             p   :=   GetHostByName(@sName);             p2   :=   iNet_ntoa(PInAddr(p^.h_addr_list^)^);             Result   :=   p2;         finally             WSACleanup;         end;     end;         end.    

     

    unit   Comm;         {************************************************************     模块名称:   串口通信     功能说明:本模块实现了两个串口控件TCustomComm和TMyComm                         TCustomComm提供不可靠的串口数据通信,TMyComm提                         供了可靠的数据通信     版本:       Version   1.0     程序员:   曾垂周     日期:       2004-06-20     更新:     修改者:     修改日期:     *************************************************************}         interface         uses           Windows,   Classes,   messages,   Dialogs,   SysUtils;         const         TIMER_R=1000;                             //接收定时器标识         TIMER_R_INTERNAL=100;             //接收定时器时隙         type         TPackage=Record             No:   Word;                                 //数据包序号             Data:   array   of   byte;           //数据包内容         end;         PPackage=^TPackage;             TEventReceived=procedure(Sender:TObject;   buff:array   of   byte;   Bytes:   Cardinal)   of   object;             TCustomComm=Class(TComponent)         private             FHandle:   THandle;             FBaudRate:Cardinal;             FComHand:THandle;             FComName:string;             FComTimeOut:TCOMMTIMEOUTS;             FInSize:DWORD;             FInBuffer:array   of   byte;             FOutSize:DWORD;             FParity:byte;             FByteSize:byte;             FStopBits:byte;             FCtsHold:DWORD;             //是否定时自动读取串口,如果是则读入数据后会产生OnReceived事件             FAutoRead:boolean;             FOnReceived:TEventReceived;                 procedure   SetComName(const   value:   string);             procedure   SetCTSHold(const   Value:   DWORD);             procedure   SetInSize(const   value:   DWORD);             procedure   SetOutSize(const   value:   DWORD);             procedure   WndProc(   var   AMsg:   TMessage);             procedure   DoTimer;                 function   ReadIn(var   buff:array   of   byte):DWORD;         public             constructor   Create(AOwner:   TComponent);override;             destructor     destroy;   override;                 property   Handle:THandle   read   FHandle;             procedure   GetTimeOut(var   rTime,rMultiplier,rConstant,wMultiplier,   wConstant:Cardinal);             procedure   SetTimeOut(rTime,rMultiplier,rConstant,wMultiplier,wConstant:Cardinal);             procedure   GetComParam(var   BaudRate:Cardinal;   var   Parity,ByteSize,StopBits:byte);             procedure   SetComParam(BaudRate:Cardinal;Parity,ByteSize,StopBits:byte);                 function   Open:boolean;             function   Active:boolean;             procedure   Close;             function   Write(buff:array   of   byte):boolean;             function   Read(var   buff:array   of   byte):DWORD;         published             property   AutoRead:   boolean   read   FAutoRead   write   FAutoRead;             property   CtsHold:       DWORD   read   FCtsHold   write   SetCTSHold;             property   InSize:     DWORD   read   FInSize   write   SetInSize;             property   OutSize:   DWORD   read   FOutSize   write   SetOutSize;             property   ComName:   string   read   FComName   write   SetComName;             property   OnReceived:   TEventReceived   read   FOnReceived   write   FOnReceived;         end;         const         TIMER_MYCOMM_S=1001;               //发送定时器标识         TIMER_MYCOMM_R=1002;               //接收超时定时器标识         TIMER_S_INTERNAL=5000;           //发送定时器时隙         LEN_BOX=7;                                   //数据包头长度         //S_TIMEOUT=30000;                       //发送超时         //R_TIMEOUT=30000;                       //接收超时             BYTE_ACK=$FF;                             //应答包标志         type         TMyComm=Class(TComponent)         private             FHandle:   THandle;             FComm:   TCustomComm;             FStartByte:   byte;                               //数据包开始标识             FSize:   Word;                                         //数据包大小             FPackNo:Word;                                       //当前希望接收的数据包号             FInBuffer:   array   of   byte;               //接收到的未处理的数据             FGoodBuffer:array   of   byte;             //接收到的已处理的数据             FOnReceived:   TEventReceived;         //数据接收完毕事件             FPackageList:TList;                           //待发送的数据包链表             FSendTime:Cardinal;                           //发送计时             FS_TimeOut:DWord;                               //发送超时设定             FR_TimeOut:DWord;                               //接收超时设定                 procedure   SetStartByte(const   Value:   byte);       //设置数据包开始标识             procedure   SetSize(const   Value:   Word);                 //设置数据报大小             procedure   DoReceive(Sender:   TObject;   buff:   array   of   byte;   bytes:   Cardinal);             procedure   SetWord(var   buff:array   of   byte;   w:Word;idx:Word);             procedure   SendPackage;             procedure   WndProc(var   AMsg:   TMessage);             procedure   DoSendTimer;             procedure   DoReceiveTimer;             procedure   ReceiveAck(pNo:Word);             function     GetWord(buff:array   of   byte;   idx:Word):Word;             function   GetComName:   String;             function   GetSize:   Word;             function   GetInSize:   Word;             function   GetOutSize:   word;             procedure   SetComName(const   Value:   String);             procedure   SetInsSize(const   Value:   Word);             procedure   SetOutSize(const   Value:   word);         public             constructor   Create(AOwner:   TComponent);override;             destructor     destroy;   override;                 function   Open:boolean;             function   Active:   boolean;             procedure   Close;                 function   Write(buff:   array   of   byte;   Start:   DWORD;   Len:   DWORD):DWORD;             procedure   GetComParam(var   BaudRate:Cardinal;   var   Parity,ByteSize,StopBits:byte);             procedure   SetComParam(BaudRate:Cardinal;Parity,ByteSize,StopBits:byte);         published             property   Handle:   THandle   read   FHandle;             property   ComName:   String   read   GetComName   write   SetComName;             property   InSize:   Word   read   GetInSize   write   SetInsSize;             property   OutSize:word   read   GetOutSize   write   SetOutSize;             property   StartByte:   byte   read   FStartByte   write   SetStartByte;             property   PackageSize:   Word   read   GetSize   write   SetSize;             property   OnReceived:   TEventReceived   read   FOnReceived   write   FOnReceived;             property   R_TimeOut:   DWord   Read   FR_TimeOut   write   FR_TimeOut;             property   S_TimeOut:   DWord   Read   FS_TimeOut   write   FS_TimeOut;             end;

    Top198楼  aliezeng77   (钝刀)   回复于 2004-12-01 17:03:58  得分 0

    implementation         {   TCustomComm   }         constructor   TCustomComm.Create(AOwner:   TComponent);     begin         Inherited   Create(AOwner);             FHandle   :=   AllocateHWnd(WndProc);         FComHand:=INVALID_HANDLE_VALUE;         FComName:='COM1';             FCtsHold:=0;         FInSize:=4096;         FOutSize:=4096;         FAutoRead:=true;             FBaudRate:=115200;         FParity:=0;         FByteSize:=8;         FStopBits:=ONESTOPBIT;             FComTimeOut.ReadIntervalTimeout   :=10;         FComTimeOut.ReadTotalTimeoutMultiplier:=0;         FComTimeOut.ReadTotalTimeoutConstant   :=0;         FComTimeOut.WriteTotalTimeoutMultiplier   :=20;         FComTimeOut.WriteTotalTimeoutConstant   :=5000;     end;         destructor   TCustomComm.destroy;     begin         Close;             DeallocateHWnd(   FHandle);         inherited;     end;         function   TCustomComm.Active:   boolean;     begin         result:=(FComHand<>INVALID_HANDLE_VALUE);     end;         procedure   TCustomComm.Close;     begin         if   Active   then         begin             SetLength(FInBuffer,0);             CloseHandle(FComHand);             FComHand:=INVALID_HANDLE_VALUE;             KillTimer(FHandle,TIMER_R);         end;     end;         function   TCustomComm.Open:   boolean;     var         ComDCB:TDCB;     begin         FcomHand:=CreateFile(pchar(FComName),GENERIC_READ   or   GENERIC_WRITE,0,NIL,OPEN_EXISTING,0,0);         if   (FcomHand<>INVALID_HANDLE_VALUE)   and   SetupComm(FcomHand,FInSize,FOutSize)                 and   GetCommState(FComHand,ComDCB)   then         begin             ComDCB.BaudRate   :=FBaudRate;             ComDCB.Parity:=FParity;             ComDCB.ByteSize   :=FByteSize;             ComDCB.StopBits   :=FStopBits;             {             ComDCB.XonLim   :=10;             ComDCB.XoffLim   :=512;             ComDCB.XonChar   :=#17;             ComDCB.XoffChar   :=#19;             ComDCB.ErrorChar   :=#63;             ComDCB.EofChar   :=#26;             ComDCB.EvtChar   :=#0;             }             if   SetCommState(FcomHand,ComDCB)   and   SetCommTimeouts(FcomHand,FComTimeOut)   then             begin                 //创建定时器,每TIMER_R_INTERNAL毫秒读一次串口                 if   SetTimer(Handle,TIMER_R,TIMER_R_INTERNAL,nil)>0   then                 begin                     SetLength(FInBuffer,FInSize);                     result:=true;                     exit;                 end;             end;         end;             CloseHandle(FComHand);         FComHand:=INVALID_HANDLE_VALUE;         result:=false;     end;         procedure   TCustomComm.SetComParam(BaudRate:   Cardinal;   Parity,   ByteSize,         StopBits:   byte);     begin         FBaudRate:=BaudRate;         FParity:=Parity;         FByteSize:=ByteSize;         FStopBits:=StopBits;     end;         procedure   TCustomComm.SetComName(const   value:   string);     begin         if   (not   active)   and   (FComName<>value)   then   FComName:=value;     end;         procedure   TCustomComm.SetInSize(const   value:   DWORD);     begin         if   (not   active)   and   (FInSize<>value)   then   FInSize:=value;     end;         procedure   TCustomComm.SetOutSize(const   value:   DWORD);     begin         if   (not   active)   and   (FOutSize<>value)   then   FOutSize:=value;     end;         procedure   TCustomComm.SetCTSHold(const   Value:   DWORD);     begin         if   (not   active)   and   (FCTSHold<>value)   then   FCTSHold:=value;     end;         procedure   TCustomComm.SetTimeOut(rTime,   rMultiplier,   rConstant,   wMultiplier,         wConstant:   Cardinal);     begin         FComTimeOut.ReadIntervalTimeout:=rTime;         FComTimeOut.ReadTotalTimeoutMultiplier:=rMultiplier;         FComTimeOut.ReadTotalTimeoutConstant:=rConstant;         FComTimeOut.WriteTotalTimeoutMultiplier:=wMultiplier;         FComTimeOut.WriteTotalTimeoutConstant:=wConstant;     end;         procedure   TCustomComm.GetComParam(var   BaudRate:   Cardinal;   var   Parity,   ByteSize,         StopBits:   byte);     begin         BaudRate:=FBaudRate;         Parity:=FParity;         ByteSize:=FByteSize;         StopBits:=FStopBits;     end;         procedure   TCustomComm.GetTimeOut(var   rTime,   rMultiplier,   rConstant,   wMultiplier,         wConstant:   Cardinal);     begin         rTime:=FComTimeOut.ReadIntervalTimeout;         rMultiplier:=FComTimeOut.ReadTotalTimeoutMultiplier;         rConstant:=FComTimeOut.ReadTotalTimeoutConstant;         wMultiplier:=FComTimeOut.WriteTotalTimeoutMultiplier;         wConstant:=FComTimeOut.WriteTotalTimeoutConstant;     end;         function   TCustomComm.ReadIn(var   buff:array   of   byte):DWORD;     var         BytesRead:DWord;         Error:DWORD;         State:TCOMSTAT;     begin         Result:=0;         if   not   Active   then   Exit;             ClearCommError(FComHand,Error,@State);         if   (fCtlHold   in   State.Flags)   then         begin             FCtsHold:=0;             Exit;         end         else             FCtsHold:=1;             if   not   ReadFile(FComHand,buff,State.cbInQue,BytesRead,nil)   then   Exit;         result:=bytesRead;     end;         function   TCustomComm.Write(buff:   array   of   byte):   boolean;     var         BytesWritten:DWord;         Error:DWORD;         State:TCOMSTAT;         Len:WORD;     begin         Result:=false;         if   not   active   then   exit;             while   true   do   //清空接收缓冲         begin             PurgeComm(FComHand,PURGE_RXCLEAR);             ClearCommError(FComHand,Error,@State);             if   State.cbInQue=0   then   break;         end;             while   true   do     //清空发送缓冲         begin             PurgeComm(FComHand,PURGE_TXCLEAR);             ClearCommError(FComHand,Error,@State);             if   State.cbOutQue=0   then   break;         end;             Len:=High(Buff)-Low(buff)+1;         if   not   WriteFile(FComHand,buff,Len,BytesWritten,nil)   then   Exit;         if   BytesWritten<Len   then   Exit;         Result:=true;     end;         procedure   TCustomComm.WndProc(var   AMsg:   TMessage);     begin         with   aMsg   do   case   aMsg.Msg   of             WM_TIMER:   if   FAutoRead   then   DoTimer;       //如果自动数据则产生DoTimer事件,在该事件中读取数据             else   DefWindowProc(   FHandle,   Msg,   WParam,   LParam);         end;   //case;     end;         {自动读取数据}     procedure   TCustomComm.DoTimer;     var         bytesRead:integer;     begin         bytesRead:=ReadIn(FInBuffer);         if   (bytesRead>0)   and   (Assigned(FOnReceived))   then             FOnReceived(self,FInBuffer,BytesRead);     end;         {主动读取数据}     function   TCustomComm.Read(var   buff:   array   of   byte):   DWORD;     begin         if   AutoRead   then   result:=0         else   result:=ReadIn(buff);     end;    

    Top199楼  aliezeng77   (钝刀)   回复于 2004-12-01 17:04:42  得分 0

    {   TMyComm   }         constructor   TMyComm.Create(AOwner:   TComponent);     begin         inherited;             FHandle:=AllocateHWnd(WndProc);         FComm:=TCustomComm.Create(self);         FPackageList:=TList.Create;                 FSize:=1017;                     //数据包大小         FStartByte:=$0A;             //起始位             FR_TimeOut   :=   30000;         FS_TimeOut   :=   30000;             FComm.OnReceived:=DoReceive;     end;         destructor   TMyComm.destroy;     begin         Close;         FComm.Free;         FPackageList.Free;         DeallocateHWnd(   FHandle);             inherited;     end;         function   TMyComm.Open:   boolean;     begin         FPackNo:=0;                       //待接收包号清零         FSendTime:=0;                   //发送计时器清零             result:=FComm.Open;     end;         function   TMyComm.Active:   boolean;     begin         result:=FComm.Active;     end;         procedure   TMyComm.Close;     begin         FComm.Close;             FInBuffer:=nil;         FGoodBuffer:=nil;     end;         function   TMyComm.Write(buff:   array   of   byte;   Start:   DWORD;   Len:   DWORD):   DWORD;     var         pNo,idx,Send,remanent:DWord;         pp:PPackage;         CheckSum:byte;         IsSending:   boolean;     begin         //如果待发送的长度为零或者待发送的数据越界则不发送,返回结果0         if   (Len=0)   or   (Length(buff)<Start+Len)   then         begin             result:=0;             exit;         end;             IsSending:=(FPackageList.Count>0);         pNo:=0;               //初始化包号         Send:=0;             //已发送字节数             while   Len-Send>FSize   do     //如果剩下的数大于数据包的长度,则继续分包         begin             new(pp);                 pp.No:=pNo;             SetLength(pp.Data,FSize+LEN_BOX);             pp.Data[0]:=FStartByte;             pp.Data[1]:=1;                                         //有后续包              SetWord(pp.Data,pp.No,2);                   //包号             SetWord(pp.Data,FSize,4);                   //数据长度             CopyMemory(@(pp.Data)[LEN_BOX-1],@buff[Start+Send],FSize);                 CheckSum:=0;             for   idx:=low(pp.Data)   to   High(pp.Data)-1   do   CheckSum:=CheckSum   xor   pp.Data[idx];             pp.Data[high(pp.Data)]:=CheckSum;       //效验和                 FPackageList.Add(pp);             Inc(pNo);             Inc(Send,FSize);         end;             remanent:=Len-Send;         new(pp);         pp.No:=pNo;         SetLength(pp.Data,remanent+LEN_BOX);         pp.Data[0]:=FStartByte;         pp.Data[1]:=0;         SetWord(pp.Data,pp.No,2);         SetWord(pp.Data,remanent,4);         CopyMemory(@(pp.Data)[LEN_BOX-1],@buff[Start+Send],remanent);             CheckSum:=0;         for   idx:=low(pp.Data)   to   High(pp.Data)-1   do   CheckSum:=CheckSum   xor   pp.Data[idx];         pp.Data[high(pp.Data)]:=CheckSum;             FPackageList.Add(pp);         FSendTime:=GetTickCount;           //设置发送时间         if   not   IsSending   then   SendPackage;             result:=Len;     end;         procedure   TMyComm.DoReceive(Sender:   TObject;   buff:   array   of   byte;   bytes:   Cardinal);     var         idx,i:Word;         Len:Word;         CheckSum:byte;         bEnd:boolean;         szPack:Word;         pNo:Word;             procedure   SendAck(pNo:Byte);         var             ack:array[0..4]   of   byte;         begin             ack[0]:=FStartByte;             ack[1]:=BYTE_ACK;             SetWord(ack,pNo,2);             ack[4]:=ack[0]   xor   ack[1]   xor   ack[2]   xor   ack[3];             FComm.Write(ack);         end;         begin         if   not   Assigned(FOnReceived)   then   exit;             {把收到的数据拷贝到未处理数据缓存中}         Len:=Length(FInBuffer);         SetLength(FInBuffer,Len+Bytes);         CopyMemory(@FInBuffer[Len],@buff[0],Bytes);             idx:=0;         while   idx<Length(FInBuffer)   do     //出来数据         begin             if   FInBuffer[idx]<>FStartByte   then   //如果不是开始标志,则Continue             begin                 inc(idx);                 Continue;             end;                 pNo:=GetWord(FInBuffer,idx+2);           //提取包号             if   (FInBuffer[idx+1]=BYTE_ACK)   and   (idx+4<=Length(FInBuffer))   then             begin                 //如果是应答包                 if   (FInBuffer[idx]   xor   FInBuffer[idx+1]   xor   FInBuffer[idx+2]                                     xor   FInBuffer[idx+3]   xor   FInBuffer[idx+4])=0   then                 begin                     CopyMemory(FInBuffer,@FInBuffer[idx+5],Length(FInbuffer)-(idx+5));                     SetLength(FInBuffer,Length(FInbuffer)-(idx+5));                     ReceiveAck(pNo);         //响应第pNo个应答包                     idx:=0;                     Continue;                 end;             end;                 if   pNo>FPackNo   then         //如果pNo大于当前要接收的包号,则Continue             begin                 inc(idx);                 Continue;             end;                 szPack:=GetWord(FInBuffer,idx+4);                           //得到包的数据大小             if   Length(FInBuffer)<Idx+szPack+LEN_BOX   then     //如果小于包的数据大小             begin                 inc(idx);                 Continue;             end;                 if   pNo<FPackNo   then               //如果是已经收到的数据包,则             begin                 SendAck(pNo);                 CopyMemory(FInBuffer,@FInBuffer[idx+szPack+LEN_BOX],Length(FInBuffer)-(idx+szPack+LEN_BOX));                 SetLength(FInBuffer,Length(FInBuffer)-(idx+szPack+LEN_BOX));                 idx:=0;             end             else   if   pNo=FPackNo   then             //如果是当前要接收的数据包             begin                 CheckSum:=0;                 for   i:=0   to   szPack+LEN_BOX-1   do   CheckSum:=CheckSum   XOR   FInBuffer[idx+i];                     if   CheckSum<>0   then   Inc(idx)                 else   begin                     SendAck(pNo);                     Inc(FPackNo);                     bEnd:=(FInBuffer[1]=0);                     SetLength(FGoodBuffer,Length(FGoodBuffer)+szPack);                     CopyMemory(@FGoodBuffer[length(FGoodBuffer)-szPack],@FInBuffer[idx+LEN_BOX-1],szPack);                     CopyMemory(FInBuffer,@FInBuffer[idx+szPack+LEN_BOX],Length(FInBuffer)-(idx+szPack+LEN_BOX));                     SetLength(FInBuffer,Length(FInBuffer)-(idx+szPack+LEN_BOX));                     KillTimer(FHandle,TIMER_MYCOMM_R);                         SetTimer(FHandle,TIMER_MYCOMM_R,R_TIMEOUT,nil);                     if   bEnd   then                     begin                         FPackNo:=0;                         FOnReceived(self,FGoodBuffer,Length(FGoodBuffer));   //触发接收完毕事件                         SetLength(FGoodBuffer,0);                     end;                     idx:=0;                 end;             end;         end;     end;        

    **********   来自----   win2000pega(景)     **************************     我现在几万条,不会超过20秒。     现在导48890条,1分13秒。     用文件流处理很快的。     代码如下:     unit   UnitXLSFile;         interface         uses         Windows,   Messages,   SysUtils,   Classes,   Graphics,   Controls,   Grids,   Forms,   Dialogs,db,dbctrls,comctrls;         const     {BOF}         CBOF             =   $0009;         BIT_BIFF5   =   $0800;         BOF_BIFF5   =   CBOF   or   BIT_BIFF5;     {EOF}         BIFF_EOF   =   $000a;     {Document   types}         DOCTYPE_XLS   =   $0010;     {Dimensions}         DIMENSIONS   =   $0000;         type         TAtributCell   =   (acHidden,acLocked,acShaded,acBottomBorder,acTopBorder,                                     acRightBorder,acLeftBorder,acLeft,acCenter,acRight,acFill);             TSetOfAtribut   =   set   of   TatributCell;             TXLSWriter   =   class(Tobject)         private             fstream:TFileStream;             procedure   WriteWord(w:word);         protected             procedure   WriteBOF;             procedure   WriteEOF;             procedure   WriteDimension;         public             maxCols,maxRows:Word;             procedure   CellWord(vCol,vRow:word;aValue:word;vAtribut:TSetOfAtribut=[]);             procedure   CellDouble(vCol,vRow:word;aValue:double;vAtribut:TSetOfAtribut=[]);             procedure   CellStr(vCol,vRow:word;aValue:String;vAtribut:TSetOfAtribut=[]);             procedure   WriteField(vCol,vRow:word;Field:TField);             constructor   create(vFileName:string);             destructor   destroy;override;         end;         procedure   SetCellAtribut(value:TSetOfAtribut;var   FAtribut:array   of   byte);     procedure   DataSetToXLS(ds:TDataSet;fname:String);     procedure   StringGridToXLS(grid:TStringGrid;fname:String);         implementation         procedure   DataSetToXLS(ds:TDataSet;fname:String);     var   c,r:Integer;         xls:TXLSWriter;     begin         xls:=TXLSWriter.create(fname);         if   ds.FieldCount   >   xls.maxcols   then             xls.maxcols:=ds.fieldcount+1;         try             xls.writeBOF;             xls.WriteDimension;             for   c:=0   to   ds.FieldCount-1   do                 xls.Cellstr(0,c,ds.Fields[c].DisplayLabel);             r:=1;             ds.first;             while   (not   ds.eof)   and   (r   <=   xls.maxrows)   do   begin                 for   c:=0   to   ds.FieldCount-1   do                     if   ds.Fields[c].AsString<>''   then                         xls.WriteField(r,c,ds.Fields[c]);                 inc(r);                 ds.next;             end;             xls.writeEOF;         finally             xls.free;         end;     end;         procedure   StringGridToXLS(grid:TStringGrid;fname:String);     var   c,r,rMax:Integer;         xls:TXLSWriter;     begin         xls:=TXLSWriter.create(fname);         rMax:=grid.RowCount;         if   grid.ColCount   >   xls.maxcols   then             xls.maxcols:=grid.ColCount+1;         if   rMax   >   xls.maxrows   then                     //   ¦¹®æ¦¡³Ì¦h¥u¯à¦s   65535   Rows             rMax:=xls.maxrows;         try             xls.writeBOF;             xls.WriteDimension;             for   c:=0   to   grid.ColCount-1   do                 for   r:=0   to   rMax-1   do                     xls.Cellstr(r,c,grid.Cells[c,r]);             xls.writeEOF;         finally             xls.free;         end;     end;         {   TXLSWriter   }         constructor   TXLSWriter.create(vFileName:string);     begin         inherited   create;         if   FileExists(vFilename)   then             fStream:=TFileStream.Create(vFilename,fmOpenWrite)         else             fStream:=TFileStream.Create(vFilename,fmCreate);             maxCols:=100;       //   <2002-11-17>   dllee   Column   À³¸Ó¬O¤£¥i¯à¤j©ó   65535,   ©Ò¥H¤£¦A³B²z         maxRows:=65535;   //   <2002-11-17>   dllee   ³o­Ó®æ¦¡³Ì¤j¥u¯à³o»ò¤j¡A½Ðª`·N¤jªº¸ê®Æ®w«Ü®e©ö´N¤j©ó³o­Ó­È     end;         destructor   TXLSWriter.destroy;     begin         if   fStream   <>   nil   then             fStream.free;         inherited;     end;         procedure   TXLSWriter.WriteBOF;     begin         Writeword(BOF_BIFF5);         Writeword(6);                       //   count   of   bytes         Writeword(0);         Writeword(DOCTYPE_XLS);         Writeword(0);     end;         procedure   TXLSWriter.WriteDimension;     begin         Writeword(DIMENSIONS);     //   dimension   OP   Code         Writeword(8);                       //   count   of   bytes         Writeword(0);                       //   min   cols         Writeword(maxRows);           //   max   rows         Writeword(0);                       //   min   rowss         Writeword(maxcols);           //   max   cols     end;         procedure   TXLSWriter.CellDouble(vCol,   vRow:   word;   aValue:   double;         vAtribut:   TSetOfAtribut);     var     FAtribut:array   [0..2]   of   byte;     begin         Writeword(3);                       //   opcode   for   double         Writeword(15);                     //   count   of   byte         Writeword(vCol);         Writeword(vRow);         SetCellAtribut(vAtribut,fAtribut);         fStream.Write(fAtribut,3);         fStream.Write(aValue,8);     end;         procedure   TXLSWriter.CellWord(vCol,vRow:word;aValue:word;vAtribut:TSetOfAtribut=[]);     var     FAtribut:array   [0..2]   of   byte;     begin         Writeword(2);                       //   opcode   for   word         Writeword(9);                       //   count   of   byte         Writeword(vCol);         Writeword(vRow);         SetCellAtribut(vAtribut,fAtribut);         fStream.Write(fAtribut,3);         Writeword(aValue);     end;         procedure   TXLSWriter.CellStr(vCol,   vRow:   word;   aValue:   String;         vAtribut:   TSetOfAtribut);     var     FAtribut:array   [0..2]   of   byte;         slen:byte;     begin         Writeword(4);                       //   opcode   for   string         slen:=length(avalue);         Writeword(slen+8);             //   count   of   byte         Writeword(vCol);         Writeword(vRow);         SetCellAtribut(vAtribut,fAtribut);         fStream.Write(fAtribut,3);         fStream.Write(slen,1);         fStream.Write(aValue[1],slen);     end;         procedure   SetCellAtribut(value:TSetOfAtribut;var   FAtribut:array   of   byte);     var           i:integer;     begin       //reset         for   i:=0   to   High(FAtribut)   do             FAtribut[i]:=0;                       if     acHidden   in   value   then               //byte   0   bit   7:                       FAtribut[0]   :=   FAtribut[0]   +   128;                   if     acLocked   in   value   then               //byte   0   bit   6:                       FAtribut[0]   :=   FAtribut[0]   +   64   ;                   if     acShaded   in   value   then               //byte   2   bit   7:                       FAtribut[2]   :=   FAtribut[2]   +   128;                   if     acBottomBorder   in   value   then   //byte   2   bit   6                       FAtribut[2]   :=   FAtribut[2]   +   64   ;                   if     acTopBorder   in   value   then         //byte   2   bit   5                       FAtribut[2]   :=   FAtribut[2]   +   32;                   if     acRightBorder   in   value   then     //byte   2   bit   4                       FAtribut[2]   :=   FAtribut[2]   +   16;                   if     acLeftBorder   in   value   then       //byte   2   bit   3                       FAtribut[2]   :=   FAtribut[2]   +   8;                   //   <2002-11-17>   dllee   ³Ì«á   3   bit   À³¥u¦³   1   ºØ¿ï¾Ü               if     acLeft   in   value   then                   //byte   2   bit   1                       FAtribut[2]   :=   FAtribut[2]   +   1               else   if     acCenter   in   value   then     //byte   2   bit   1                       FAtribut[2]   :=   FAtribut[2]   +   2               else   if   acRight   in   value   then         //byte   2,   bit   0   dan   bit   1                       FAtribut[2]   :=   FAtribut[2]   +   3               else   if   acFill   in   value   then           //byte   2,   bit   0                       FAtribut[2]   :=   FAtribut[2]   +   4;     end;         procedure   TXLSWriter.WriteWord(w:   word);     begin         fstream.Write(w,2);     end;         procedure   TXLSWriter.WriteEOF;     begin         Writeword(BIFF_EOF);         Writeword(0);     end;         procedure   TXLSWriter.WriteField(vCol,   vRow:   word;   Field:   TField);     begin         case   field.DataType   of               ftString,ftWideString,ftBoolean,ftDate,ftDateTime,ftTime:                   Cellstr(vcol,vrow,field.asstring);               ftAutoInc,ftSmallint,ftInteger,ftWord:                   CellWord(vcol,vRow,field.AsInteger);               ftFloat,   ftBCD:                   CellDouble(vcol,vrow,field.AsFloat);         else                   Cellstr(vcol,vrow,EmptyStr);       //   <2002-11-17>   dllee   ¨ä¥L«¬ºA¼g¤JªÅ¥Õ¦r¦ê         end;     end;    

    ------------------------------------------------------------------------

         问一下:谁有一个好办法,可以不断地检测网络是否连通?     最好给出代码!多谢                       //======================================================     uses     WinInet     function     IsInternet:     Boolean;         begin               if     InternetCheckConnection('www.microsoft.com',     1,     0)     then                       Result     :=     True               else                       Result     :=     False;         end;            

    为表格加上预警机制(颜色突出显示)     功能:在表格中有个预警列表,可以对没个字段设定大于,小于,等于,之间等范围,并设定颜色突出显示。             TWarnings   =   class(TCollection)     //可以加一些方法         end;             TWarning   =   class(TCollectionItem)         private             FFieldName:   String;             FFieldDisplay:   String;             FOperator:   TOperator;             FValue1:   String;             FValue2:   String;             FValue1Field:   String;             FValue2Field:   String;             FColor:   TColor;             public             constructor   Create(Collection:   TCollection);   override;         published             property   FieldDisplay:   String   read   FFieldDisplay   write   FFieldDisplay;             property   FieldName:   String   read   FFieldName   write   FFieldName;             property   Operator:   TOperator   read   FOperator   write   FOperator;             property   Value1:   String   read   FValue1   write   FValue1;             property   Value1Field:   String   read   FValue1Field   write   FValue1Field;             property   Value2:   String   read   FValue2   write   FValue2;             property   Value2Field:   String   read   FValue2Field   write   FValue2Field;             property   Color:   TColor   read   FColor   write   FColor;         end;         为表格价格加上TWarnings属性     在DrawColumnCell事件里重画         DrawColumnCell事件内容如下:         if   FWarings.Count   >   0   then         begin             for   I   :=   0   to   FWarings.Count   -   1   do             begin                 W   :=   TWarning(FWarings.Items[I]);                 if   W.FieldName   <>   Column.FieldName   then   Continue;                     vFieldName   :=   DataSource.DataSet.FindField(W.FieldName);                 if   not   Assigned(vFieldName)   then   Continue;                 if   not   TryStrToFloat(vFieldName.AsString,   vFieldFloat)   then   Continue;                     if   W.Value1Field   <>   ''   then                 begin                     vValue1Feid   :=   DataSource.DataSet.FindField(W.Value1Field);                     if   Assigned(vValue1Feid)   then                     begin                         if   not   TryStrToFloat(vValue1Feid.AsString,   vValue1Float)   then   Continue;                     end                     else                         if   not   TryStrToFloat(W.Value1,   vValue1Float)   then   Continue;                 end                 else                     if   not   TryStrToFloat(W.Value1,   vValue1Float)   then   Continue;                     if   W.Value2Field   <>   ''   then                 begin                     vValue2Feid   :=   DataSource.DataSet.FindField(W.Value2Field);                     if   Assigned(vValue2Feid)   then                     begin                         if   not   TryStrToFloat(vValue2Feid.AsString,   vValue2Float)   then   Continue;                     end                     else                         if   not   TryStrToFloat(W.Value2,   vValue2Float)   then   Continue;                 end                 else                     if   not   TryStrToFloat(W.Value2,   vValue2Float)   then   Continue;                     if   CheckOperation(W.Operator,   vFieldFloat,   vValue1Float,   vValue2Float)   then                     Canvas.Brush.Color   :=   W.Color   else   Continue;                 Canvas.FillRect(Rect);                 case   Column.Alignment   of                     taLeftJustify   :   Canvas.TextOut(Rect.Left   +   2,   Rect.Top   +   2,   vFieldName.AsString);                     taCenter             :   Canvas.TextOut((Rect.Right   -   Canvas.TextWidth(vFieldName.AsString))   div   2,                                                         Rect.Top   +   2,   vFieldName.AsString);                     taRightJustify:   Canvas.TextOut(Rect.Right   -   Canvas.TextWidth(vFieldName.AsString)   -   2,                                                         Rect.Top   +   2,   vFieldName.AsString);                 end;                     end;         end;    

    有不少人提到过Delphi数学运算当中四舍五入的问题     经常得不到预期的结果,这里就贴出一个Delphi的Round函数     使用的是强制转换成int64然后再转换回double的方式来完成     写得比较临时,也没有做二次修改,只求得暂时性应付     -------------------------------------------------------     //此部分为C++代码,对于Delphi就屏蔽掉     //     //#include   <math.h>     //     //RoundDown=================================================Begin     //--------------------------------------     //无条件舍弃     //例:1.535       //只取小数点后两位,其余无打件舍弃得1.53     //使用方法:RoundDown(1.535,2)     //返回值:1.53     //--------------------------------------     //double   RoundDown(double   Value,Byte   ADigit)     //{     //       double   Result=Value;     //       if(ADigit>18)     //             return   Result;     //       double   DigitValue=pow(10,ADigit);     //       Result*=DigitValue;     //       Result=floorl(Result);     //       Result/=DigitValue;     //       return   Result;     //}     //RoundDown===================================================End     //     //Round=====================================================Begin     //--------------------------------------     //四舍五入     //例:1.535       //保留小数点后两位,做四舍五入得1.54     //使用方法:Round(1.535,2)     //返回值:1.54     //--------------------------------------     //double   Round(double   Value,Byte   ADigit)     //{     //       double   Result=Value;     //       if(ADigit>18)     //             return   Result;     //       double   DigitValue=pow(10,ADigit);     //       Result+=0.5/DigitValue;     //       Result*=DigitValue;     //       Result=floorl(Result);     //       Result/=DigitValue;     //       return   Result;     //}     //Round=======================================================End     //RoundUp===================================================Begin     //--------------------------------------     //无条件进位     //例:1.533       //保留小数点后两位,余数进位得1.54     //使用方法:RoundUp(1.533,2)     //返回值:1.54     //--------------------------------------     //double   RoundUp(double   Value,Byte   ADigit)     //{     //       double   Result=Value;     //       if(ADigit>18)     //             return   Result;     //       double   DigitValue=pow(10,ADigit);     //       Result*=DigitValue;     //       Result=floorl(Result);     //       Result/=DigitValue;     //       if(Value>Result)     //             Result+=1/DigitValue;     //       return   Result;     //}     //RoundUp=====================================================End         uses           math;     function   DRound(Value:double;cnt:byte):double;     var           fTmp:double;           nTmp:double;           k:int64;     begin           Result:=Value;           if   cnt>18   then   exit;           nTmp:=Power(10.0,cnt);           fTmp:=0.5;           fTmp:=fTmp/nTmp;           Result:=fTmp+Result;           Result:=Result*nTmp;           k:=0;           asm                 fld   qword   ptr   Result                 //__ftol   begin   这一段做double   to   int64   转换                 push   ebp                 mov   ebp,esp                 LEA   ESP,k                 wait                 fstcw   word   ptr   [ebp-$04]                 wait                 mov   al,[ebp-$03]                 or   [ebp-$04],$00000c01                 fldcw   word   ptr   [ebp-$04]                 fistp   qword   ptr   [ebp-$0c]                 mov   [ebp-$03],al                 fldcw   word   ptr   [ebp-$04]                 mov   eax   ,[ebp-$0c]                 mov   edx,[ebp-$08]                 mov   esp,ebp                 pop   ebp                 //__ftol   end                 push   esp                 lea   esp,k                 mov   [esp],eax                 add   esp,4                 mov   [esp],edx                 mov   esp,ebp                 pop   esp                 fild   qword   ptr   k                 fstp   qword   ptr   Result                 fld   qword   ptr   nTmp                 fdivr   qword   ptr   Result                 fstp   qword   ptr   Result           end;     end;     function   DRoundUp(Value:double;cnt:byte):double;     var           fTmp:double;           nTmp:double;           k:int64;     begin           Result:=Value;           if   cnt>18   then   exit;           nTmp:=Power(10.0,cnt);           fTmp:=1;           fTmp:=fTmp/nTmp;           Result:=Result*nTmp;           k:=0;           asm                 fld   qword   ptr   Result                 //__ftol   begin     这一段做double   to   int64   转换                 push   ebp                 mov   ebp,esp                 LEA   ESP,k                 wait                 fstcw   word   ptr   [ebp-$04]                 wait                 mov   al,[ebp-$03]                 or   [ebp-$04],$00000c01                 fldcw   word   ptr   [ebp-$04]                 fistp   qword   ptr   [ebp-$0c]                 mov   [ebp-$03],al                 fldcw   word   ptr   [ebp-$04]                 mov   eax   ,[ebp-$0c]                 mov   edx,[ebp-$08]                 mov   esp,ebp                 pop   ebp                 //__ftol   end                 push   esp                 lea   esp,k                 mov   [esp],eax                 add   esp,4                 mov   [esp],edx                 mov   esp,ebp                 pop   esp                 fild   qword   ptr   k                 fstp   qword   ptr   Result                 fld   qword   ptr   nTmp                 fdivr   qword   ptr   Result                 fstp   qword   ptr   Result           end;           if   Result<Value   then   Result:=Result+fTmp;     end;     function   DRoundDown(Value:double;cnt:byte):double;     var           fTmp:double;           nTmp:double;           k:int64;     begin           Result:=Value;           if   cnt>18   then   exit;           nTmp:=Power(10.0,cnt);           Result:=Result*nTmp;           k:=0;           asm                 fld   qword   ptr   Result                 //__ftol   begin     这一段做double   to   int64   转换                 push   ebp                 mov   ebp,esp                 LEA   ESP,k                 wait                 fstcw   word   ptr   [ebp-$04]                 wait                 mov   al,[ebp-$03]                 or   [ebp-$04],$00000c01                 fldcw   word   ptr   [ebp-$04]                 fistp   qword   ptr   [ebp-$0c]                 mov   [ebp-$03],al                 fldcw   word   ptr   [ebp-$04]                 mov   eax   ,[ebp-$0c]                 mov   edx,[ebp-$08]                 mov   esp,ebp                 pop   ebp                 //__ftol   end                 push   esp                 lea   esp,k                 mov   [esp],eax                 add   esp,4                 mov   [esp],edx                 mov   esp,ebp                 pop   esp                 fild   qword   ptr   k                 fstp   qword   ptr   Result                 fld   qword   ptr   nTmp                 fdivr   qword   ptr   Result                 fstp   qword   ptr   Result           end;     end;

    Top236楼  yeeyee   (易一 )   回复于 2005-04-22 19:17:46  得分 0

    //代码,递归清空文本框   Text,     //变成其他类似的递归操作     //函数     procedure   TFormCYBase.ClearText(AControl:TWinControl);     var         I:   Integer;     begin         for   I   :=   0   to   AControl.ControlCount   -   1   do         //   Iterate         begin             //需清空处理控件             if   AControl.Controls[i]   is   TCustomEdit   then             begin                 (AControl.Controls[i]   as   TCustomEdit).Text:='';             end;             if   AControl.Controls[i]   is   TCustomComboBox   then             begin                 (AControl.Controls[i]   as   TCustomComboBox).ClearSelection;             end;             //可以   作为   父亲的控件处理事件。             if   AControl.Controls[i]   is   TCustomControl     then             begin                 ClearText(AControl.Controls[i]   as   TCustomControl);             end;         end;     end;         //调用     procedure   TFormCYBase.FormCreate(Sender:   TObject);     begin         ClearText(Self);     end;

    Top237楼  yeeyee   (易一 )   回复于 2005-04-22 19:20:01  得分 0

    //异常类,Application   对象统一管理异常。         unit   UntMyExcept;         interface         uses         SysUtils,   DB,   Classes,   Menus,   Forms,   OLEDBAccess,   IdException,   Dialogs;         Type                 TMyErrCls=Class(TObject)         Public             Procedure   MyExceptionHandler(Sender:TObject;EInstance:Exception);         end;         implementation         uses   UntCommon;         //------------------------------------------------------------     {编写自己的异常处理句柄}     procedure   TMyErrCls.MyExceptionHandler(Sender:TObject;   EInstance:Exception);     var         ErrorFile:TextFile;         FileName,ETips:string;         Content:string;         st:string;     //临时的字符串         FindFlag:Boolean;     Begin     {截获出现的异常,并存入文件ErrorInfo.txt.}         FileName:=gAppPath+'/ErrorInfo.txt';         //打开文件         AssignFile(ErrorFile,FileName);             if   (not   FileExists(FileName))   then     ReWrite(ErrorFile);         ReSet(ErrorFile);         //检查今天是否有异常事件记录在文件ErrorInfo.txt中         ETips:=formatdatetime('yyyy''年''mm''月''dd''日',now);         FindFlag:=false;         While   not   SeekEof(ErrorFile)   do         begin             Readln(ErrorFile,Content);             if   Pos(ETips,Content)<>0   then             begin                 FindFlag:=True;                 break;             end;         end;         Append(ErrorFile);         //今天未有异常事件记录,则加入一行直线隔开。         if   (not   FindFlag)   then   Writeln(ErrorFile,'-------------------------------------------------------------------------------');         ETips:=ETips+formatdatetime('''_''hh''时''nn''分''ss''秒-->',now);         Writeln(ErrorFile,ETips+EInstance.ClassName+':'+EInstance.Message);         {关闭文件}         CloseFile(ErrorFile);         {对出现的异常显示中文提示}         If   EInstance   is   EDivByZero   then                 ETips:='除数不能为零!'         else   if   EInstance   is   EAccessViolation   then                 ETips:='访问了无效的内存区域!'             //====易会坚加入2005年3月29日下午====         else     if   (EInstance   is   EOLEDBError)   then         begin             ETips:=(EInstance   as   EOLEDBError).Message         end                                       //====易会坚加入2005年3月29日下午====             else   if   (EInstance   is   EDatabaseError)   then                 ETips:='数据库操作出现错误!'         else   if   (EInstance   is   EFOpenError)   then                 ETips:='文件不能打开!'         else   if   (EInstance   is   EReadError)   then                 ETips:='文件不能正确读出!'         else   if   (EInstance   is   EWriteError)   then                 ETips:='文件不能写入!'         else   if   (EInstance   is   EConvertError)   then                 ETips:='非法的类型转换!'         else   if   (EInstance   is   EInOutError)   then                 ETips:='请将磁盘插入驱动器!'         else   if   (EInstance   is   EMenuError)   then                 ETips:='程序主菜单出现错误!'         else   if   (EInstance   is   EOutOfMemory)   then                 ETips:='内存不足!'                             //====易会坚加入2005年4月8日下午====         else     if   (EInstance   is   EIdConnectException)   then         begin             st:=(EInstance   as   EIdConnectException).Message;             //ShowMessage(IntToStr((EInstance   as   EIdConnectException).e));             if   st='Socket   Error   #   10061'+#13+#10+'Connection   refused.'   then             begin                 ETips:='连接文件服务器出错,文件服务器拒绝连接,请稍后连接';             end;         end         //====易会坚加入2005年4月8日下午====             //====易会坚加入2005年4月8日下午====         else     if   (EInstance   is   EIdConnClosedGracefully)   then         begin             st:=(EInstance   as   EIdConnClosedGracefully).Message;             //ShowMessage(IntToStr((EInstance   as   EIdConnectException).e));             if   st='Connection   Closed   Gracefully.'   then             begin                 //ETips:='连接文件服务器出错,有可能网络出现了问题,请稍后连接';                 exit;             end;         end         //====易会坚加入2005年4月8日下午====                 //====易会坚加入2005年3月29日下午====         else     if   (EInstance   is   EIdProtocolReplyError)   then         begin                                                 //   用户名称,密码没有输入的代码。             st:=(EInstance   as   EIdProtocolReplyError).Message;             //用户名称不对,为空的情况。             if   st='''USER   '':   Invalid   number   of   parameters'+#13+#10   then             begin                 ETips:='登录文件服务器的用户名称不对,请认真输入';             end;             //密码输入错误的情况。             if   Copy(st,Length(st)-15,14)='cannot   log   in.'   then             begin                 ETips:='该用户不能登录文件传输服务器,请认真输入';             end;                 //EIdProtocolReplyError:/dfd:   The   system   cannot   find   the   file   specified.             //密码输入错误的情况。             if   Copy(st,Length(st)-43,42)='The   system   cannot   find   the   file   specified.'   then             begin                 ETips:='客户端或者、文件服务器端路径错误,请认真设置';             end;         end         //====易会坚加入2005年3月29日下午====                     //====易会坚加入2005年3月29日下午====         else     if   (EInstance   is   EIdSocketError)   then         begin             st:=(EInstance   as   EIdSocketError).Message;             //没有连接的代码             if   st='Not   Connected'     then             begin                 ETips:='下载文件出错,中断了文件服务器的连接,请稍后下载';             end;             //下载文件断开了连接服务器关掉了的异常处理             if   st='Terminating   connection.'+#13+#10     then             begin                 ETips:='下载文件出错,与服务器断开了连接,请稍后下载';             end;             //上传出现问题的代码。             st:=(EInstance   as   EIdSocketError).Message;             //服务器断开的代码             if   st='Socket   Error   #   10053'+#13+#10+'Software   caused   connection   abort.'   then             begin                 ETips:='传输文件出现错误,与文件服务器断开了连接,请稍后重新传输';             end;             //网络出现问题的代码             if   st='Socket   Error   #   10054'+#13+#10+'Connection   reset   by   peer.'   then             begin                 ETips:='传输文件出现错误,网络出现了问题,请稍后重新传输';             end;                 //没有找到文件服务器主机的情况。             if   st='Socket   Error   #   10054'   then             begin                 ETips:='网络出现了问题,请稍后重试';             end;             //没有找到文件服务器主机的情况。             if   st='Socket   Error   #   11001'+#13+#10+'Host   not   found.'   then             begin                 ETips:='连接文件服务器出错,没有找到服务器,请认真输入';             end;             if   Copy(st,Length(st)-15,14)='cannot   log   in.'   then             begin                 ETips:='连接文件服务器出错,该用户不能登录文件传输服务器,请认真';             end;             if   st='Socket   Error   #   10060'+#13+#10+'Connection   timed   out.'   then             begin                 ETips:='连接服务器超时,请稍后继续连接';             end;             //服务器没有打开的情况。             if   st='Socket   Error   #   10061'+#13+#10+'Connection   refused.'   then             begin                 ETips:='连接文件服务器出错,文件服务器拒绝访问';             end;         end         //====易会坚加入2005年3月29日下午====             //====易会坚加入2005年4月12日19====         else     if   (EInstance   is   EIdClosedSocket)   then         begin             st:=(EInstance   as   EIdClosedSocket).Message;             if   st='Disconnected.'   then             begin                 //ETips:='连接文件服务器出错,有可能网络出现了问题,请稍后连接';                 exit;             end;         end         //====易会坚加入2005年4月12日19====                     else                 ETips:=EInstance.ClassName+':'+EInstance.Message;         Application.MessageBox(PChar(ETips),'错误信息');     end;             end.             program   PrjFTPClient;         uses         Forms,         FTPModel   in   'FTPModel.pas',         UntCommon   in   '../Common/UntCommon.pas',         UntFTPView   in   'UntFTPView.pas'   {FormFTPView},         UntMyExcept   in   'UntMyExcept.pas',         Controller   in   'Controller.pas',         UntCYBaseForm   in   'UntCYBaseForm.pas'   {FormCYBase},         UntFTPClientSet   in   'UntFTPClientSet.pas'   {FormFTPClientSet};         {$R   *.res}     var         MyErrObj:   TMyErrCls;   {声明TMyClass类的一个变量}         begin         Application.Initialize;         MyErrObj:=TMyErrCls.Create;   {创建TMyClass类的一个实例}         Application.OnException:=MyErrObj.MyExceptionHandler;   {响应OnException事件}               Application.CreateForm(TFormFTPView,   FormFTPView);         Application.Run;     end.    

    var     用SQL语句操作EXECL.         i:Integer;     begin                                                                                                             //厂商资料表         OpenDialog1.Title   :=   '请选择相应的Excel文件';         OpenDialog1.Filter   :=   'Excel(*.xls)|*.xls';     try       begin         if   OpenDialog1.Execute   then             MyExcelFile   :=OpenDialog1.FileName;             ADOConnection1.Close;             ADOConnection1.ConnectionString   :='Provider=Microsoft.Jet.OLEDB.4.0;Data   Source='+MyExcelFile+';Extended   Properties=excel   8.0;Persist   Security   Info=False';             ADOConnection1.Connected   :=true;             adoquery1.Close;             ADOQuery1.SQL.Clear;             adoquery1.SQL.Add(   'SELECT   *     FROM   [sheet1$]');             adoquery1.Open;             ProgressBar1.Max   :=   ADOQuery1.RecordCount;    

     

    try         st:=TStringList.create;         st.text:='胜利扩大发生开绿灯法';         ....     finally         Freeandnil(st);     end;

    ----------------------------------------------------------------------通过指定方式分割字符串     function   SplitString(const   SourceChar,   SplitChar:   string):   TStringList;     var         Tmp:   string;         I:   Integer;     begin         Result   :=   TStringList.Create;         Tmp   :=   SourceChar;         I   :=   Pos(SplitChar,   SourceChar);         while   I   <>   0   do         begin             Result.Add(Copy(Tmp,   0,   I   -   1));             Delete(Tmp,1,i);             I   :=   Pos(SplitChar,   Tmp);         end;         Result.Add(Tmp);     end;           procedure   TForm1.btnTestClick(Sender:   TObject);     var         slTitle:   TStringList;         sSplitString:   string;         I:   Integer;     begin         slTitle   :=   SplitString('afsdfsdaaa,bbfdsfsdb,ccc',',');         for   I   :=   0   to   slTitle.Count-1   do         sSplitString   :=   sSplitString   +   slTitle.Strings[I]+#13;         ShowMessage(sSplitString);         slTitle.Free;     end;     -------------------------------------------------

    //根据字符串创建类,参考   Delphi   开发人员指南,           //函数,AClassName要创建的窗体名字,     function   TLoginComp.CreateAClass(const   AClassName:   string):   TObject;     var         C   :   TFormClass;         SomeObject:   TObject;     begin         C   :=   TFormClass(FindClass(AClassName));         SomeObject   :=   C.Create(nil);         Result   :=   SomeObject;     end;         function   TLoginComp.ExecuteShowModal(AStrForm:string):TFormCYBase;     var         SomeComp:   TObject;     begin         SomeComp   :=   CreateAClass(AStrForm);         try             (SomeComp   as   TFormCYBase).ShowModal;         finally             SomeComp.Free;         end;     end;         //调用单元,注意,调用的类要注册。     procedure   TForm1.BitBtn4Click(Sender:   TObject);     begin         self.LoginComp1.ExecuteShowModal('TFormLogin')     end;         initialization                                             begin         RegisterClasses([TFormLogin]);     end;

     

      unit   Unit1;         interface         uses         Windows,   Messages,   SysUtils,   Variants,   Classes,   Graphics,   Controls,   Forms,         Dialogs,   StdCtrls,   ExtCtrls;         type         TForm1   =   class(TForm)             Image1:   TImage;             Edit1:   TEdit;             Button1:   TButton;             procedure   Button1Click(Sender:   TObject);         private             procedure   GetImage(sStr:string);             procedure   GetLogFont(iAnc:integer;fCanvas:tCanvas);             procedure   DrawFive(x,y,r:integer;fCanvas:tCanvas);             function   GetPoint(nI:integer;nJ:integer;var   NAnc:integer):Tpoint;                 {   Private   declarations   }         public             {   Public   declarations   }         end;         var         Form1:   TForm1;         implementation         {$R   *.dfm}         procedure   TForm1.Button1Click(Sender:   TObject);     begin         if   self.Edit1.text=''   then             exit         else             GetImage(edit1.Text);     end;         procedure   Tform1.Getimage(sStr:String);     var         nX,nY,nZ:integer;         nPoint:Tpoint;     begin         nY:=length(widestring(sstr));         if   ny>18   then   ny:=18;             image1.Canvas.Pen.Width:=3;         image1.Canvas.Ellipse(50,20,170,140);//110,80         drawfive(110,80,20,image1.Canvas   );         for   nx:=1   to   ny   do   begin             npoint:=GetPoint(nx,ny,nz);             image1.Canvas.Font.Size:=10;             //image1.Canvas.Font.Style:=[fsBold];             getlogfont(nz,image1.Canvas);             image1.Canvas.TextOut(npoint.x,npoint.y,copy(widestring(sStr),nx,1));             end;     end;         procedure   Tform1.GetLogFont(iAnc:integer;fCanvas:tCanvas);     var         FlogFont:LogFont;     begin         FillChar(FLogFont,Sizeof(TLogFont),0);                 With   FlogFont   do                 begin                   lfHeight:=fCanvas.font.Height;                   lfWidth:=0;                   lfEscapement:=iAnc;           //想旋转多少度,修改这里的参数就可以了啊                   lforientation:=lfEscapement;                   lfWeight:=Fw_Normal;                   lfItalic:=0;                   lfUnderline:=0;                   lfStrikeOut:=0;                   lfCharSet:=GB2312_CHARSET;                   StrPCopy(lfFaceName,'宋体');                   lfQuality:=PROOF_QUALITY;                   lfOutPrecision:=OUT_TT_ONLY_PRECIS;                   lfClipPrecision:=CLIP_DEFAULT_PRECIS;                   lfPitchAndFamily:=Variable_Pitch;                 end;                 fCanvas.Font.Handle:=CreateFontIndirect(FLogFont);     end;     function   Tform1.GetPoint(ni:integer;nj:integer;var   Nanc:integer):Tpoint;     var         pPoint:Tpoint;         RAn:Extended;         tempI:integer;     begin         {18个字:360             9个字:180             0个字:0         }         tempI:=100*(16-nJ+2*nI);         if   tempI<2700   then             tempI:=2700-tempI         else             tempi:=6300-tempI;             Nanc:=tempi-900;             ran:=pi*(tempi/1800);         pPoint.x:=110+round(55*cos(ran));         pPoint.Y:=80-round(55*sin(ran));         result:=pPoint;         end;     procedure   Tform1.DrawFive(x,y,r:integer;fCanvas:tCanvas);     var         oldColor:Tcolor;         nX:integer;         nR:integer;         tempRgn:hrgn;         pPoint:Array[0..9]   of   Tpoint;     begin         for   nx:=0   to   9   do   begin             if   (nx   mod   2=0)   then   nR:=r   else   nR:=round(r*sin(pi/10)/sin(pi*126/180));             pPoint[nx].X:=x+round(nR*cos(pi*(nx/5+0.5)));             pPoint[nx].y:=y-round(nR*sin(pi*(nx/5+0.5)));         end;         oldcolor:=fcanvas.Brush.Color;         fcanvas.Brush.Color:=clblack;             temprgn:=CreatePolygonRgn(ppoint[0],10,ALTERNATE);         FillRgn(fcanvas.Handle,temprgn,fcanvas.Brush.Handle);                 fcanvas.Brush.Color:=oldcolor;     end;     end.

     

    261楼  rouqing   (*冰雨&双子座奇缘*)   回复于 2005-05-10 20:16:51  得分 0

    “如何让CB写的EXE文件执行再生成另一个EXE文件   ”         http://community.csdn.net/Expert/topic/3961/3961831.xml?temp=.8354914         本人发布在cb版的一个代码,改成delphi的也不难吧?         是不是你给我发消息了?但是我这里消息里边已经没有你的mail地址了,我把邮件正文给你贴过来吧,今天刚写的:         我上网不方便,实在抱歉这么晚发给你,不会耽误你的工作吧?收到测试解决你的问题后记得回复我一下!我都忘记是哪个帖子回复你的问题了,呵呵.再有什么问题就再联系吧;     我是上网卡拨号上网的,网速很慢,我就不直接给你发源程序了,你自己写写看,或者直接     复制也可以使用的,没有用到别的组件;         开发测试环境:Win98se+CBuilder6+up4;     //---------------------------------------------------------------------------         开发两个程序,主程序是MainForm.exe,(界面上只放一个bitbtn,为了触发生成新程序的代码),你要生成的程序是Simple.exe,(界面上只放一个bitbtn),放到资源里边调用的;         其中simple.exe中的bitbtn代码如下:主要是显示一个效果而已:caption是"确定"     窗体的标题是:Simple   Window         void   __fastcall   TResForm::btnOK1Click(TObject   *Sender)     {         ShowMessage("This   is   Simple   Window");                     }         打开记事本,写下如下的文字:         EXEFILE     RCDATA   "Simple.exe"         另外保存为myres.rc文件,   复制myres.rc和simple.exe到D:/ProgramFiles/Borland/CBuilder6/Bin目录(你放到你的目录下边),启动MS-DOS方式,确定是在上述目录下,执行   brcc32   myres.rc命令,可以生成myres.res文件,就是我们要的资源文件,你可以看看myres.res和simple.exe的文件大小是一样的!不过利用资源这样做出来主程序的体积是比较大的,切记!     然后MainForm.exe的代码如下:         //---------------------------------------------------------------------------     //功能:由资源生成可执行文件     //代码:DongZhe     //WriteDate:2005-05-08,15:43     //---------------------------------------------------------------------------     #include   <vcl.h>     #pragma   hdrstop         #include   "Unit1.h"     //---------------------------------------------------------------------------     #pragma   package(smart_init)     #pragma   resource   "*.dfm"         #pragma   resource   "myres.res"//必须加上这句,就是我们要调用的资源文件;         TForm1   *Form1;     //---------------------------------------------------------------------------     __fastcall   TForm1::TForm1(TComponent*   Owner)                     :   TForm(Owner)     {     }     //---------------------------------------------------------------------------         void   __fastcall   TForm1::BitBtn1Click(TObject   *Sender)     {         TResourceStream   *rs;         try         {             rs=new   TResourceStream((int)HInstance,"EXEFILE",RT_RCDATA);             try             {                 //从资源里边提取出来,然后保存到硬盘上,在当前目录下;                 rs->SaveToFile(ExtractFilePath(Application->ExeName)+"NewSimple.exe");             }             catch(...)             {                 delete   rs;                 rs=NULL;             }         }         __finally         {             delete   rs;             rs=NULL;         }                 //如果文件存在就执行!!         if(FileExists("NewSimple.exe"))         {             AnsiString   s=ExtractFilePath(Application->ExeName)+"NewSimple.exe";             WinExec(s.c_str(),SW_SHOW);         }             //等NewSimple.exe完全调入到内存后,发送模拟鼠标单击消息,就可看到"This   is   //Simple   Window"的对话框出现了;实际上这个时间也可以调整的,或者不要这句代码       //你自己写写看吧,我主要是怕你调用一些比较大的程序恐怕是需要一些初始化的时间       //的;             Sleep(2000);             //由NewSimple.exe的Form的caption得到窗口句柄的         HWND   hWnd=FindWindow(NULL,"Simple   Window");         if(hWnd)         {             //由NewSimple.exe的BitBtn的caption得到按钮句柄的             HWND   hBtnWnd=FindWindowEx(hWnd,0,NULL,"确定");             if(hBtnWnd)                 SendMessage(hBtnWnd,BM_CLICK,0,0);               }             //问题解决了,效果还不错吧?呵呵;         //如果调用完了NewSimple.exe,也可以编写代码关闭窗口,删除保存在硬盘上的         //NewSimple.exe,节省资源嘛,呵呵;         /*             if(   NewSimple.exe窗体的句柄存在   )             {                 SendMessage(h,WM_CLOSE,0,0);                 if   (   文件在硬盘   )                     DeleteFile(...);             }           */         }    

    unit   setvol;         //----------------------------------     //                     音量控制的类     //     声名:我只是在网上找了相关资料,并     //                 然后加了些改动。因为对MMSYSTEM     //                 不是很熟悉,可能还有很多错误。     //     //     BY   ekinsoft     //     QQ   2735462     //     email     ekinsoft@qq.com     //-----------------------------------         {   使用方法:     在USES中包含,setvol和mmsystem     声名两个类型     Tvolume       --   用来保存声音左右声道的数据     Pmixercontrol     ---   混音控制台?具体是什么我不知道,反正必须声明         指定   Pmixercontrol   的ID,整型     具体声卡相关设备的ID是多少我就不知道了。你可以一个一个试。     在指定   Pmixercontrol   的ID前请一定用   new(Pmixercontrol)   来分配内存。         setvolume(Pmixercontrol,Tvolume);       设置声音用这个之前请分别为Tvolume的left和right指定值     GETvolume(Pmixercontrol)   ;   获取指定设备的声音   返回的是一个Tvolume   ,有两个属性   left   和   right方法如下                     showmessage(inttostr(   GETvolume(Pmixercontrol).left))         setism(Pmixercontrol,[boolean])   设置指定设备是否静音,默认为TRUE         getism(Pmixercontrol)   获取指定设备是否静音   ,返回一个BOOLEAN类型             }         interface           uses   windows,mmsystem;           type     Tvolume=record     left,right:word;     end;         procedure   fillstruct(control:PMixerControl;var   Cdetails:TMixercontroldetails);     function   getpeak(control:PMixerControl;var   peak:integer):boolean;       function   setvolume(control:Pmixercontrol;   volume:Tvolume):boolean;       function   setism(control:Pmixercontrol;Mute:boolean   =   True):boolean;     function   getism(control:Pmixercontrol):boolean;     function   getvolume(control:Pmixercontrol):Tvolume;         var     mcontrols:array   of   PMixerControl;       fmixerhandle:HMixer;         implementation           procedure   fillstruct(control:PMixerControl;var   Cdetails:TMixercontroldetails);     begin     Cdetails.cbStruct:=sizeof(cdetails);     cdetails.dwControlID:=Control.dwControlID;     cdetails.cbDetails:=sizeof(integer);     cdetails.hwndOwner:=0;       end;           function   getpeak(control:PMixerControl;var   peak:integer):boolean;     var     details:TMixerControlDetailsSigned;     cdetails:TMixercontroldetails;     begin     Result:=false;     if   control.dwControlType<>   mixercontrol_controltype_peakmeter   then   exit;     cdetails.cChannels:=1;     cdetails.paDetails:=@details;     fillstruct(control,cdetails);     result:=mixerGetControlDetails(fmixerhandle,@cdetails,MIXER_GETCONTROLDETAILSF_VALUE)=0;       end;               ///--------------------------     ///   设置音量的函数     ///--------------------------     function   setvolume(control:Pmixercontrol;   volume:Tvolume):boolean;     var     details:array[0..30]   of   integer;     cdetails:TMixercontroldetails;     begin     fillstruct(control,cdetails);     cdetails.cChannels:=2;     cdetails.paDetails:=@details;     details[0]:=volume.left;     details[1]:=volume.right;     result:=mixerSetControlDetails(fmixerhandle,@cdetails,MIXER_GETCONTROLDETAILSF_VALUE)=0;     volume.left:=details[0];     volume.right:=details[1];     end;                 ///--------------------------     ///   获取音量的函数     ///--------------------------     function   getvolume(control:Pmixercontrol):Tvolume;     var     volume   :   tvolume;     details:array[0..30]   of   integer;     cdetails:TMixercontroldetails;     begin     fillstruct(control,cdetails);     cdetails.cChannels:=2;     cdetails.paDetails:=@details;     mixerGetControlDetails(fmixerhandle,@cdetails,MIXER_GETCONTROLDETAILSF_VALUE);     volume.left:=details[0];     volume.right:=details[1];     result:=   volume;     end;             ///--------------------------     ///   设置静音的函数     ///--------------------------     function   setism(control:Pmixercontrol;Mute:boolean   =   True):boolean;     var     details:array[0..30]   of   integer;     cdetails:TMixercontroldetails;     begin     control.dwControlID   :=   control.dwControlID   +1;         fillstruct(control,cdetails);     cdetails.cChannels:=1;     cdetails.paDetails:=@details;       case   integer(mute)   of         0:details[0]:=0;         1:details[0]:=1;       end;     result:=mixerSetControlDetails(fmixerhandle,@cdetails,MIXER_GETCONTROLDETAILSF_VALUE)=0;     control.dwControlID   :=   control.dwControlID   -1;     end;                 ///--------------------------     ///   获取静音的函数           ///--------------------------     function   getism(control:Pmixercontrol):boolean;     var     details:array[0..30]   of   integer;     cdetails:TMixercontroldetails;     begin     control.dwControlID   :=   control.dwControlID   +1;     fillstruct(control,cdetails);     cdetails.cChannels:=1;     cdetails.paDetails:=@details;     mixerGetControlDetails(fmixerhandle,@cdetails,MIXER_GETCONTROLDETAILSF_VALUE);     if   details[0]=0   then   result:=false   else   result:=true;     control.dwControlID   :=   control.dwControlID   -1;     end;         end.               拆行打印中文字拆行函数     ===========================     //C++   Builder版     AnsiString   LimitStringCut(const   AnsiString   Value,                                                           int   &LimitNum,                                                           const   int   StartPos=1)     {           AnsiString   Result;           int   iPos=StartPos;               int   iLen=Value.Length();           if(iPos>iLen)                 return   "";           if(LimitNum>iLen-iPos+1)                 LimitNum=iLen-iPos+1;           int   iLimitNum=LimitNum+1;           if(iLimitNum>iLen-iPos+1)                 iLimitNum=LimitNum;           //取得最大长度子串           Result=Value.SubString(iPos,LimitNum);           if(iLimitNum!=LimitNum)           {                 AnsiString   tmpStr=Value.SubString(iPos,iLimitNum);                 //取得最大长度+1,用意在于判断是否最后取的是汉字的前一半                 //下面是使用转换成Unicode后的字串长度来做判断的                 if(WideString(tmpStr).Length()==WideString(Result).Length())                 {                       //可能存在半个汉字                     if(LimitNum>1)                             //最后一个是汉字的高字节,                             //因为不能超最大长度,                             //所以在这里宁可少取一个字符                             Result=Value.SubString(iPos,LimitNum-1);                 }           }           return   Result;     }     ----------------------------------------------------------     //Delphi版     function   LimitStringCut(const   Value:String;                                                       var   LimitNum:integer;                                                       const   StartPos:integer=1):string;     var           iPos:Integer;           iLen:Integer;           iLimitNum:Integer;           tmpStr:String;     begin           iPos:=StartPos;           iLen:=Length(Value);           if   iPos>iLen   then           begin                 Result:=   '';                 exit;           end;           if   LimitNum>iLen-iPos+1   then   LimitNum:=iLen-iPos+1;           iLimitNum:=LimitNum+1;           if   iLimitNum>iLen-iPos+1   then   iLimitNum:=LimitNum;           //取得最大长度子串           Result:=Copy(Value,iPos,LimitNum);           if   iLimitNum<>LimitNum   then           Begin                 tmpStr:=Copy(Value,iPos,iLimitNum);                 //取得最大长度+1,用意在于判断是否最后取的是汉字的前一半                 //下面是使用转换成Unicode后的字串长度来做判断的                 if   Length(WideString(tmpStr))=Length(WideString(Result))   then                 begin                       //可能存在半个汉字                       //最后一个是汉字的高字节,                       //因为不能超最大长度,                       //所以在这里宁可少取一个字符                       if   LimitNum>1   then   Result:=Copy(Value,iPos,LimitNum-1);                 end;           end;     end;     ----------------------------------------------------------     //VB版     Private   Sub   Copy(ByRef   Dst()   As   Byte,   _                                       ByRef   Src()   As   Byte,   _                                       ByVal   iStart   As   Integer,   _                                       ByVal   iLen   As   Integer)             Dim   i   As   Integer             For   i   =   0   To   iLen   -   1                   Dst(i)   =   Src(i   +   iStart   -   1)             Next     End   Sub         Function   LimitStringCut(ByVal   Value   As   String,   _                                                       ByRef   LimitNum   As   Integer,   _                                                       Optional   StartPos   As   Integer   =   1)   As   String               Dim   iPos   As   Integer           Dim   iLen   As   Integer           Dim   iLimitNum   As   Integer           Dim   tmpStr()   As   Byte           Dim   LimitString()   As   Byte                     iPos   =   StartPos           iLen   =   LenB(StrConv(Value,   vbFromUnicode))                     If   iPos   >   iLen   Then                 LimitString   =   ""                 Exit   Function           End   If           If   LimitNum   >   iLen   -   iPos   +   1   Then   LimitNum   =   iLen   -   iPos   +   1           iLimitNum   =   LimitNum   +   1           If   iLimitNum   >   iLen   -   iPos   +   1   Then   iLimitNum   =   LimitNum           ReDim   LimitString(LimitNum   -   1)           //取得最大长度子串           Copy   LimitString,   StrConv(Value,   vbFromUnicode),   iPos,   LimitNum           If   iLimitNum   <>   LimitNum   Then                           ReDim   tmpStr(iLimitNum   -   1)                 Copy   tmpStr,   StrConv(Value,   vbFromUnicode),   iPos,   iLimitNum                 //取得最大长度+1,用意在于判断是否最后取的是汉字的前一半                 //下面是使用转换成Unicode后的字串长度来做判断的                             If   LenB(StrConv(tmpStr,   vbUnicode))   =   LenB(StrConv(LimitString,   vbUnicode))   Then                       //可能存在半个汉字                       //最后一个是汉字的高字节,                       //因为不能超最大长度,                       //所以在这里宁可少取一个字符                       If   LimitNum   >   1   Then                             ReDim   LimitString(LimitNum   -   1)                             Copy   LimitString,   StrConv(Value,   vbFromUnicode),   iPos,   LimitNum   -   1                       End   If                 End   If           End   If           LimitStringCut   =   StrConv(LimitString,   vbUnicode)     End   Function     =========================================     示例:     function   LimitStringCut(const   Value:String;                                                     var   LimitNum:integer;                                                     const   StartPos:integer=1):string;         比如现在有如下数据:     ---------------------------------------------------------     s:='asdfjklsdfj没什么东西sldk;fjas这中间还有中文字a;dfjks;dfkjs;df'     ---------------------------------------------------------     而一行只能印得下20个字符,那么就先调用:     iLen:=20;     iPos:=1;     s1:=LimitStringCut(s,iLen,iPos);     本意是要取20个字节长度,但是由于这当中第二十个字符是个汉字的高字节,帮而不能拆出来,而若取得它,那么又超过20上字节,打不下,帮而少取一个,得:     s1='asdfjklsdfj没什么东'     同时iLen返回实际取得的长度:     iLen=19     此时下一次取则应该当从第二十个字符开始取,帮而     inc(iPos,iLen);     接着再取下一串:     s1:=LimitStringCut(s,iLen,iPos);     ...       

     

    //***********************************************************************//     //                                                                                                                                               //     //       插件选择框的接口实现单元                                                                                         //     //       单元名:   TransSelectFrameUnit                                                                                 //     //       功能:   定义插件制作所用选择框                                                                                 //     //       日期:   2004   年   6月   7日                                                                                               //     //                                                                                                                                               //     //***********************************************************************//         interface         uses         Windows,   Messages,   Classes,   Controls,   Graphics,   ExtCtrls,   SysUtils;         type         TChangeSizeStyle   =   (csbLeftTop,               //   左上改变尺寸                                                 csbLeft,                     //   往左改变尺寸                                                 csbLeftBottom,         //   左下改变尺寸                                                 csbBottom,                 //   往下改变尺寸                                                 csbRightBottom,       //   左右下改变尺寸                                                 csbRight,                   //   往右改变尺寸                                                 csbRightTop,             //   右上改变尺寸                                                 csbTop                         //   往上改变尺寸                                                 );         const         //   常量   0         CNS_STATIC_ZERO                               =               $00;             //   常量   1         CNS_STATIC_ONE                                 =               $01;             //   常量   2         CNS_STATIC_TWO                                 =               $02;             //   常量   3         CNS_STATIC_THREE                             =               $03;             //   常量   4         CNS_STATIC_FOUR                               =               $04;             //   常量   5         CNS_STATIC_FIVE                               =               $05;             //   常量   6         CNS_STATIC_SIX                                 =               $06;             //   常量   7         CNS_STATIC_SEVEN                             =               $07;             //   常量   8         CNS_STATIC_EIGHT                             =               $08;             //   常量   50         CNS_STATIC_FIFTY                             =               50;             //   常量   255         CNS_STATIC_TWO_BAI_FIVE               =               $FF;             //   空指针         CNS_POINT_IS_NULL                           =               NIL;             //   数据无效         CNS_DATA_IS_NULLLITY                     =               $00;         const         wayLeftTop             =               0;         //   改变左、上边框         wayLeft                   =               1;         //   改变左边框         wayLeftBottom       =               2;         //   改变左、下边框         wayBottom               =               3;         //   改变下边框         wayRightBottom     =               4;         //   改变右、下边框         wayRight                 =               5;         //   改变右边框         wayRightTop           =               6;         //   改变右、上边框         wayTop                     =               7;         //   改变上边框         type         TCanChangeEvent   =   procedure(Sender:   TObject;   var   CanChange:   Boolean;                                                                 var   Pt:   TPoint)   of   object;             TCanChangeResizeEvent   =   procedure(Sender:   TObject;   Style:   TChangeSizeStyle;                                                         var   CanChange:   Boolean;   var   Pt:   TPoint)   of   object;         //***********************************************************************//     //                                                                                                                                               //     //       尺寸修改方块类                                                                                                             //     //                                                                                                                                               //     //***********************************************************************//     type         TCustomChangeSizeBox   =   class(TCustomControl)         private             FSize:   Integer;             FStyle:   TChangeSizeStyle;             FOnCanChangeSize:   TCanChangeEvent;             procedure   SetSize(const   Value:   Integer);             procedure   WMLButtonDown(var   Message:   TWMLBUTTONDOWN);   message   WM_LBUTTONDOWN;             procedure   WMLButtonUp(var   Message:   TWMLButtonUp);   message   WM_LBUTTONUP;             procedure   WMMouseMove(var   Message:   TWMMouseMove);   message   WM_MOUSEMOVE;         protected             //   当前是否在改变尺寸             IsChangeSize:   Boolean;                 //   鼠标左键按下后所处一位置             OldPt:   TPoint;                 //   屏蔽属性             property   Width;             property   Height;                 //   设置新的位置             procedure   SetNewPos(const   Pt:   TPoint);   virtual;         public             constructor   Create(AOwner:   TComponent);   override;                 property   Color;             property   Visible;             property   Cursor;             property   Size:   Integer   read   FSize   write   SetSize;             property   Style:   TChangeSizeStyle   read   FStyle   write   FStyle;                 property   OnCanChangeSize:   TCanChangeEvent   read   FOnCanChangeSize   write   FOnCanChangeSize;         end;

    Top-----------------------------------------------------------------------------    //***********************************************************************//     //                                                                                                                                               //     //       选择框类                                                                                                                         //     //                                                                                                                                               //     //***********************************************************************//     type         TTransSelectFrame   =   class(TGraphicControl)         private             FActive:   Boolean;             FOnActive:   TNotifyEvent;             FOnMove:   TNotifyEvent;             FOnCanMove:   TCanChangeEvent;             FOnCanResize:   TCanChangeResizeEvent;             FData:   Pointer;             FParentObject:   DWORD;                 procedure   SetcsbBottomCursor(const   Value:   TCursor);             procedure   SetcsbLeftBottomCursor(const   Value:   TCursor);             procedure   SetcsbLeftCursor(const   Value:   TCursor);             procedure   SetcsbLeftTopCursor(const   Value:   TCursor);             procedure   SetcsbRightBottomCursor(const   Value:   TCursor);             procedure   SetcsbRightCursor(const   Value:   TCursor);             procedure   SetcsbRightTopCursor(const   Value:   TCursor);             procedure   SetcsbTopCursor(const   Value:   TCursor);             function   GetcsbBottomCursor:   TCursor;             function   GetcsbLeftBottomCursor:   TCursor;             function   GetcsbLeftCursor:   TCursor;             function   GetcsbLeftTopCursor:   TCursor;             function   GetcsbRightBottomCursor:   TCursor;             function   GetcsbRightCursor:   TCursor;             function   GetcsbRightTopCursor:   TCursor;             function   GetcsbTopCursor:   TCursor;                 procedure   SetActive(const   Value:   Boolean);             function   GetVisible:   Boolean;             procedure   SetVisible(const   Value:   Boolean);             function   GetColor:   TColor;             procedure   SetColor(const   Value:   TColor);             function   GetStyle:   TPenStyle;             procedure   SetStyle(const   Value:   TPenStyle);             function   GetCursor:   TCursor;             function   GetOnActive:   TNotifyEvent;             function   GetOnMove:   TNotifyEvent;             procedure   SetCursor(const   Value:   TCursor);             procedure   SetOnActive(const   Value:   TNotifyEvent);             procedure   SetOnMove(const   Value:   TNotifyEvent);             function   GetOnResize:   TNotifyEvent;             procedure   SetOnResize(const   Value:   TNotifyEvent);             function   GetActive:   Boolean;             function   GetParent:   TWinControl;             function   GetHeight:   Integer;             function   GetLeft:   Integer;             function   GetTop:   Integer;             function   GetWidth:   Integer;             procedure   SetHeight(const   Value:   Integer);             procedure   SetLeft(const   Value:   Integer);             procedure   SetTop(const   Value:   Integer);             procedure   SetWidth(const   Value:   Integer);             function   GetOnCanMove:   TCanChangeEvent;             function   GetOnCanResize:   TCanChangeResizeEvent;             procedure   SetOnCanMove(const   Value:   TCanChangeEvent);             procedure   SetOnCanResize(const   Value:   TCanChangeResizeEvent);             procedure   SetData(const   Value:   Pointer);             function   GetData:   Pointer;         protected             OldPt:   TPoint;                 //   当前是否在改变尺寸     //         IsChangerSize:   Boolean;                 //   当前是否在移动             IsMove:   Boolean;                 //   八个方向的尺寸改变方块             ChangeBoxs:   Array[wayLeftTop..wayTop]   of   TCustomChangeSizeBox;             procedure   Paint;   override;             procedure   SetParent(AParent:   TWinControl);   override;                 //   设置尺寸方块的新位置             procedure   SetBoxPos;   virtual;             procedure   CanChange(Sender:   TObject;   var   CanChange:   Boolean;                                                     var   Pt:   TPoint);   virtual;                 //   设置尺寸方块的可见性             procedure   SetBoxVisible;   virtual;                 procedure   MouseDown(Button:   TMouseButton;   Shift:   TShiftState;                 X,   Y:   Integer);   override;             procedure   MouseMove(Shift:   TShiftState;   X,   Y:   Integer);   override;             procedure   MouseUp(Button:   TMouseButton;   Shift:   TShiftState;                 X,   Y:   Integer);   override;         public             constructor   Create(AOwner:   TComponent);   override;             destructor   Destroy;   override;                 property   Left:   Integer   read   GetLeft   write   SetLeft;             property   Top:   Integer   read   GetTop   write   SetTop;             property   Width:   Integer   read   GetWidth   write   SetWidth;             property   Height:   Integer   read   GetHeight   write   SetHeight;                 property   Parent:   TWinControl   read   GetParent   write   SetParent;             property   Active:   Boolean   read   GetActive   write   SetActive;             property   Cursor:   TCursor   read   GetCursor   write   SetCursor;             property   Style:   TPenStyle   read   GetStyle   write   SetStyle;             property   Color:   TColor   read   GetColor   write   SetColor;             property   Visible:   Boolean   read   GetVisible   write   SetVisible;                 property   Data:   Pointer   read   GetData   write   SetData;                 property   csbLeftTopCursor:   TCursor   read   GetcsbLeftTopCursor   write   SetcsbLeftTopCursor;             property   csbLeftCursor:   TCursor   read   GetcsbLeftCursor   write   SetcsbLeftCursor;             property   csbLeftBottomCursor:   TCursor   read   GetcsbLeftBottomCursor   write   SetcsbLeftBottomCursor;             property   csbBottomCursor:   TCursor   read   GetcsbBottomCursor   write   SetcsbBottomCursor;             property   csbRightBottomCursor:   TCursor   read   GetcsbRightBottomCursor   write   SetcsbRightBottomCursor;             property   csbRightCursor:   TCursor   read   GetcsbRightCursor   write   SetcsbRightCursor;             property   csbRightTopCursor:   TCursor   read   GetcsbRightTopCursor   write   SetcsbRightTopCursor;             property   csbTopCursor:   TCursor   read   GetcsbTopCursor   write   SetcsbTopCursor;                 property   OnMouseDown;             property   OnMouseMove;             property   OnMouseUp;             property   OnActive:   TNotifyEvent   read   GetOnActive   write   SetOnActive;             property   OnResize:   TNotifyEvent   read   GetOnResize   write   SetOnResize;             property   OnMove:   TNotifyEvent   read   GetOnMove   write   SetOnMove;             property   OnCanResize:   TCanChangeResizeEvent   read   GetOnCanResize   write   SetOnCanResize;             property   OnCanMove:   TCanChangeEvent   read   GetOnCanMove   write   SetOnCanMove;         end;     --------------------------------------------------------

    implementation         {   TChangeSizeBox   }         //***********************************************************************//     //                                                                                                                                               //     //       构造函数                                                                                                                         //     //                                                                                                                                               //     //***********************************************************************//     constructor   TCustomChangeSizeBox.Create(AOwner:   TComponent);     begin         inherited;         //   设置初始尺寸         Self.Size   :=   5;         Self.Color   :=   clWhite;         Self.FStyle   :=   csbLeftTop;         Self.IsChangeSize   :=   False;         Self.FOnCanChangeSize   :=   NIL;         Self.Visible   :=   True;             Self.ParentFont   :=   False;     end;         //***********************************************************************//     //                                                                                                                                               //     //       设置移动方块的新座标                                                                                                 //     //       参数:                                                                                                                               //     //                   Pt                       :               新的位置                                                                   //     //       返回值:   无                                                                                                                     //     //                                                                                                                                               //     //***********************************************************************//     procedure   TCustomChangeSizeBox.SetNewPos(const   Pt:   TPoint);     begin         //   设置新的位置         case   Self.FStyle   of             //   左上             csbLeftTop:             begin                 Self.Left   :=   Pt.X   -   CNS_STATIC_TWO;                 Self.Top     :=   Pt.Y   -   CNS_STATIC_TWO;             end;                 //   左             csbLeft:             begin                 Self.Left   :=   Pt.X   -   CNS_STATIC_TWO;             end;                 //   左下             csbLeftBottom:             begin                 Self.Left   :=   Pt.X   -   CNS_STATIC_TWO;                 Self.Top     :=   Pt.Y   -   CNS_STATIC_THREE;             end;                 //     下             csbBottom:             begin                 Self.Top   :=   Pt.Y   -   CNS_STATIC_THREE;             end;                 //   右下             csbRightBottom:             begin                 Self.Left   :=   Pt.X   -   CNS_STATIC_THREE;                 Self.Top     :=   Pt.Y   -   CNS_STATIC_THREE;             end;                 //   右             csbRight:             begin                 Self.Left   :=   Pt.X   -   CNS_STATIC_THREE;             end;                 //   右上             csbRightTop:             begin                 Self.Left   :=   Pt.X   -   CNS_STATIC_THREE;                 Self.Top     :=   Pt.Y   -   CNS_STATIC_TWO;             end;                 //   上             csbTop:             begin                 Self.Top   :=   Pt.Y   -   CNS_STATIC_TWO;             end;         end;     end;         //***********************************************************************//     //                                                                                                                                               //     //       设置移动方块的尺寸                                                                                                     //     //       参数:                                                                                                                               //     //                   Value                 :               新尺寸                                                                       //     //       返回值:   无                                                                                                                     //     //                                                                                                                                               //     //***********************************************************************//     procedure   TCustomChangeSizeBox.SetSize(const   Value:   Integer);     begin         if   Self.FSize   =   Value   then               Exit;         Self.FSize   :=   Value;             //   设置新的长度和高度         Self.Width   :=   Size;         Self.Height   :=   Size;     end;         //***********************************************************************//     //                                                                                                                                               //     //       处理鼠标左键按下消息                                                                                                 //     //                                                                                                                                               //     //***********************************************************************//     procedure   TCustomChangeSizeBox.WMLButtonDown(var   Message:   TWMLBUTTONDOWN);     var         Pt:   TPoint;     begin         //   取鼠标位置         GetCursorPos(Pt);             //   转换座标         Pt   :=   Self.Parent.ScreenToClient(Pt);             //   保存鼠标的原始位置         Self.OldPt   :=   Point(Pt.X   -   Self.Left,   Pt.Y   -   Self.Top);             //   捕捉鼠标         SetCapture(Self.Handle);         Self.IsChangeSize   :=   True;     end;         //***********************************************************************//     //                                                                                                                                               //     //       处理鼠标左键释放消息                                                                                                 //     //                                                                                                                                               //     //***********************************************************************//     procedure   TCustomChangeSizeBox.WMLButtonUp(var   Message:   TWMLButtonUp);     begin         //   不是拖动         Self.IsChangeSize   :=   False;         //   释放鼠标         ReleaseCapture;     end;         //***********************************************************************//     //                                                                                                                                               //     //       处理鼠标移动消息                                                                                                         //     //                                                                                                                                               //     //***********************************************************************//     procedure   TCustomChangeSizeBox.WMMouseMove(var   Message:   TWMMouseMove);     var         Pt:   TPoint;         X,   Y:   Integer;         Can:   Boolean;     begin         if   not   Self.IsChangeSize   then               Exit;             //   取鼠标的位置         GetCursorPos(Pt);             //   座标转换         Pt   :=   Self.Parent.ScreenToClient(Pt);         X   :=   Pt.X   -   Self.OldPt.X;         Y   :=   Pt.Y   -   Self.OldPt.Y;             Pt   :=   Point(X,   Y);         Can   :=   True;             //   是否执行事件         if   Assigned(Self.FOnCanChangeSize)   then         begin               Self.FOnCanChangeSize(Self,   Can,   Pt);         end;             if   NOT   Can   then               Exit;             //   设置新的位置         Self.SetNewPos(Pt);     end;    

    -------------------------------------------------------

    asm             push   p.Data             cmp   pCount,   1             JB   @exec             JE   @One             cmp   pCount,   2             JE   @two             @ThreeUp:                 CLD                 mov   ecx,   pCount                 sub   ecx,   2                 mov   edx,   4                 add   edx,   4             @loop:                 mov   eax,   [pParams]                 mov   eax,   [eax]+edx                 mov   eax,   [eax]                 push   eax                 add   edx,   4                 Loop   @loop             @Two:                 mov   ecx,   [pParams]                 mov   ecx,   [ecx]+4                 mov   ecx,   [ecx]             @One:                 mov   edx,   [pParams]//10//[DispParams(Params).rgvarg][0]//[pParams]                 mov   edx,   [edx]                 mov   edx,   [edx]             @exec:                 mov   eax,   p.Data                 cmp   eax,   0                 je   @1                 jne   @call                 @1:                     mov   eax,   edx                     mov   edx,   ecx                     pop   ecx                     jmp   @call                 @call:                     call   P.Code         end;    

     


    最新回复(0)