借鉴学习 DELPHI 通用函数哈哈

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

http://m.blog.csdn.net/blog/dragonjiang5460/1196927

2006-9-8阅读2016 评论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.

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.