关于Delphi通用涵数

Delphi方面 专栏收录该内容
9 篇文章 0 订阅


   
                                  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.  
 

Top
9楼  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;

Top
16楼  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//&frac14;&AElig;&Euml;&atilde;Controls×&Uuml;&iquest;í&para;&Egrave;&ordm;&Iacute;&cedil;&szlig;&para;&Egrave;  
          AllCtrlWidth   :=   AllCtrlWidth   +   Controls[Cnt].Width;  
          AllCtrlHeight   :=   AllCtrlHeight   +   Controls[Cnt].Height;  
      end;  
   
      if   Parent.Width   >   AllCtrlWidth   then//&frac14;&AElig;&Euml;&atilde;Controls&Ouml;&reg;&frac14;&auml;&micro;&Auml;&iquest;í&para;&Egrave;  
          SpaceWidth   :=   (Parent.Width   -   AllCtrlWidth)   div   (Count   +   1)  
      else  
          SpaceWidth   :=   0;  
   
      if   Parent.Height   >   AllCtrlHeight   then//&frac14;&AElig;&Euml;&atilde;Controls&Ouml;&reg;&frac14;&auml;&micro;&Auml;&cedil;&szlig;&para;&Egrave;  
          SpaceHeight   :=   (Parent.Height   -   AllCtrlHeight)   div   (Count   +   1)  
      else  
          SpaceHeight   :=   0;  
   
      if   IsHorizontal   then  
          for   Cnt   :=   0   to   Count   -   1   do//&acute;&brvbar;&Agrave;íControls&Euml;&reg;&AElig;&frac12;&Icirc;&raquo;&Ouml;&Atilde;  
              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//&acute;&brvbar;&Agrave;íControls&acute;&sup1;&Ouml;±&Icirc;&raquo;&Ouml;&Atilde;  
              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;  
 

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

牛     太牛了       向你们学习

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

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

Top
120楼  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.  
 

Top
126楼  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.  
 


 

 


Top
147楼  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.

Top
149楼  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;  
 

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

up!

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

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

Top
152楼  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   ;  
      //&sup1;&acirc;±ê&Ocirc;&Uacute;&iquest;&Oslash;&frac14;&thorn;&micro;&Auml;×&icirc;×ó&sup2;à  
      if   (X   <=   Precision)   and   (Y   >   Precision)   and   (Y   <   H   -   Precision)then  
      begin  
          SC_MANIPULATE   :=   $F001;  
          WinControl.Cursor   :=   crSizeWE;  
      end  
        //&sup1;&acirc;±ê&Ocirc;&Uacute;&iquest;&Oslash;&frac14;&thorn;&micro;&Auml;×&icirc;&Oacute;&Ograve;&sup2;à  
      else   if   (X   >=   W   -   Precision)   and   (Y   >   Precision)   and   (Y   <   H   -   Precision)   then  
      begin  
          SC_MANIPULATE   :=   $F002;  
          WinControl.Cursor   :=   crSizeWE;  
      end  
        //&sup1;&acirc;±ê&Ocirc;&Uacute;&iquest;&Oslash;&frac14;&thorn;&micro;&Auml;×&icirc;&Eacute;&Iuml;&sup2;à  
      else   if   (X   >   Precision)   and   (X   <   W   -   Precision)   and   (Y   <=   Precision)   then  
      begin  
          SC_MANIPULATE   :=   $F003;  
          WinControl.Cursor   :=   crSizeNS;  
      end  
      //&sup1;&acirc;±ê&Ocirc;&Uacute;&iquest;&Oslash;&frac14;&thorn;&micro;&Auml;×ó&Eacute;&Iuml;&frac12;&Ccedil;  
      else   if   (X   <=   Precision)   and   (Y   <=   Precision)   then  
      begin  
          SC_MANIPULATE   :=   $F004;  
          WinControl.Cursor   :=   crSizeNWSE;  
      end  
      //&sup1;&acirc;±ê&Ocirc;&Uacute;&iquest;&Oslash;&frac14;&thorn;&micro;&Auml;&Oacute;&Ograve;&Eacute;&Iuml;&frac12;&Ccedil;  
      else   if   (X   >=   W   -Precision)   and   (Y   <=   Precision)   then  
      begin  
          SC_MANIPULATE   :=   $F005;  
          WinControl.Cursor   :=   crSizeNESW     ;  
      end  
      //&sup1;&acirc;±ê&Ocirc;&Uacute;&iquest;&Oslash;&frac14;&thorn;&micro;&Auml;×&icirc;&Iuml;&Acirc;&sup2;à  
      else   if   (X   >   Precision)   and   (X   <   W   -   Precision)   and   (Y   >=   H   -   Precision)   then  
      begin  
          SC_MANIPULATE   :=   $F006;  
          WinControl.Cursor   :=   crSizeNS;  
      end  
      //&sup1;&acirc;±ê&Ocirc;&Uacute;&iquest;&Oslash;&frac14;&thorn;&micro;&Auml;×ó&Iuml;&Acirc;&frac12;&Ccedil;  
      else   if   (X   <=   Precision)   and   (Y   >=   H   -   Precision)   then  
      begin  
          SC_MANIPULATE   :=   $F007;  
          WinControl.Cursor   :=   crSizeNESW;  
      end  
      //&sup1;&acirc;±ê&Ocirc;&Uacute;&iquest;&Oslash;&frac14;&thorn;&micro;&Auml;&Oacute;&Ograve;&Iuml;&Acirc;&frac12;&Ccedil;  
      else   if   (X   >=   W   -   Precision)     and     (Y   >=   H   -   Precision)   then  
      begin  
          SC_MANIPULATE   :=   $F008;  
          WinControl.Cursor   :=   crSizeNWSE;  
      end  
      //&sup1;&acirc;±ê&Ocirc;&Uacute;&iquest;&Oslash;&frac14;&thorn;&micro;&Auml;&iquest;&Iacute;&raquo;§&Ccedil;&oslash;&pound;¨&Ograve;&AElig;&para;&macr;&Otilde;&ucirc;&cedil;&ouml;&iquest;&Oslash;&frac14;&thorn;&pound;&copy;  
      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;

Top
198楼  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;  
 

Top
199楼  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                     //   &brvbar;&sup1;&reg;&aelig;&brvbar;&iexcl;&sup3;&Igrave;&brvbar;h&yen;u&macr;à&brvbar;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   &Agrave;&sup3;&cedil;&Oacute;&not;O¤&pound;&yen;i&macr;à¤j&copy;ó   65535,   &copy;&Ograve;&yen;H¤&pound;&brvbar;A&sup3;B&sup2;z  
      maxRows:=65535;   //   <2002-11-17>   dllee   &sup3;o&shy;&Oacute;&reg;&aelig;&brvbar;&iexcl;&sup3;&Igrave;¤j&yen;u&macr;à&sup3;o&raquo;ò¤j&iexcl;A&frac12;&ETH;&ordf;`·N¤j&ordf;&ordm;&cedil;ê&reg;&AElig;&reg;w&laquo;&Uuml;&reg;e&copy;&ouml;&acute;N¤j&copy;ó&sup3;o&shy;&Oacute;&shy;&Egrave;  
  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   &sup3;&Igrave;&laquo;á   3   bit   &Agrave;&sup3;&yen;u&brvbar;&sup3;   1   &ordm;&Oslash;&iquest;&iuml;&frac34;&Uuml;  
            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   ¨&auml;&yen;L&laquo;&not;&ordm;A&frac14;g¤J&ordf;&Aring;&yen;&Otilde;&brvbar;r&brvbar;ê  
      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;

Top
236楼  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;

Top
237楼  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
    点赞
  • 0
    评论
  • 1
    收藏
  • 一键三连
    一键三连
  • 扫一扫,分享海报

©️2021 CSDN 皮肤主题: 大白 设计师:CSDN官方博客 返回首页
实付
使用余额支付
点击重新获取
扫码支付
钱包余额 0

抵扣说明:

1.余额是钱包充值的虚拟货币,按照1:1的比例进行支付金额的抵扣。
2.余额无法直接购买下载,可以购买VIP、C币套餐、付费专栏及课程。

余额充值