DELPHI程序注册与管理-CSDN博客

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

。。。

dephi 精彩代码