dephi 精彩代码

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;



//////如何用代码自动建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.



一个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;


一个可以为其父控件提供从浏览器拖入文件功能的类：

{-----------------------------------------------------------------------------
 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;


//--[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!');

。。。