• 设为首页
  • 点击收藏
  • 手机版
    手机扫一扫访问
    迪恩网络手机版
  • 关注官方公众号
    微信扫一扫关注
    公众号

精彩的Delphi代码

原作者: [db:作者] 来自: [db:来源] 收藏 邀请

【巨分贴,望版主置顶】,请大家将自认为实用,精彩的Delphi代码(包括自己写的!)贴出来!供彼此共同交流学习!

lingyun2003 (虚心求教)     2004-07-19 17:47:58 在 Delphi / VCL组件开发及应用 提问

此念头源于在jsp论坛看到的这样的建议。请大家踊跃参加,由于每次最多只能给分100,(同时希望版主放宽分数限制给我   :))我会另开贴加分的!自己抛砖引玉先。  
                                     
   
   
                                  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码值,并进行相加得到注册码.  
 
问题点数:0、回复次数:282
4楼  Lwg0901   (伤心人)  回复于 2004-07-19 18:13:39  得分 0

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;  
 
5楼  lingyun2003   (虚心求教)  回复于 2004-07-19 20:47:13  得分 0

//////如何用代码自动建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;
8楼  tonylk   (=www.tonixsoft.com=)  回复于 2004-07-20 15:52:52  得分 0

一个管理最近使用过的文件的类:  
   
  {-----------------------------------------------------------------------------  
    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.  
 
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;  
   
 
10楼  tonylk   (=www.tonixsoft.com=)  回复于 2004-07-20 15:57:48  得分 0

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.  
 
11楼  tonylk   (=www.tonixsoft.com=)  回复于 2004-07-20 16:01:20  得分 0

一段支持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  
    &n

鲜花

握手

雷人

路过

鸡蛋
该文章已有0人参与评论

请发表评论

全部评论

专题导读
上一篇:
matlab遗传算法工具箱发布时间:2022-07-18
下一篇:
遗传算法MATLAB实现(2):一元函数优化举例发布时间:2022-07-18
热门推荐
阅读排行榜

扫描微信二维码

查看手机版网站

随时了解更新最新资讯

139-2527-9053

在线客服(服务时间 9:00~18:00)

在线QQ客服
地址:深圳市南山区西丽大学城创智工业园
电邮:jeky_zhao#qq.com
移动电话:139-2527-9053

Powered by 互联科技 X3.4© 2001-2213 极客世界.|Sitemap