DELPHI程序注册码设计（转载）
思路是这样的:程序运行时先检测注册表,如果找到注册项,则表明已经注册,如果没有找到注册项,则提示要求注册.
<注册例程>
在DELPHI下新建一工程,放置Edit1,Edit2,Label1,Label2,Button1组件.具体代码如下:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls,Registry;//在此加上Registry以便调用注册表.
type
TForm1 = class(Tform)
Button1: Tbutton;
Edit1: Tedit;
Edit2: Tedit;
Label1: Tlabel;
Label2: Tlabel;
procedure Button1Click(Sender: Tobject);
procedure FormCreate(Sender: Tobject);
private
Function Check():Boolean;
Procedure CheckReg();
Procedure CreateReg();
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
Pname:string; //全局变量,存放用户名和注册码.
Ppass:integer;
implementation
{$R *.DFM}
Procedure TForm1.CreateReg();//创建用户信息.
var Rego:Tregistry;
begin
Rego:=Tregistry.Create;
Rego.RootKey:=HKEY_USERS;
rego.OpenKey(‘.DEFAULTSoftwareAngelSoftDemo‘,True);//键名为AngelSoftDemo,可自行修改.
Rego.WriteString(‘Name‘,Pname);//写入用户名.
Rego.WriteInteger(‘Pass‘,Ppass);//写入注册码.
Rego.Free;
ShowMessage(‘程序已经注册,谢谢!‘);
CheckReg; //刷新.
end;
Procedure TForm1.CheckReg();//检查程序是否在注册表中注册.
var Rego:Tregistry;
begin
Rego:=Tregistry.Create;
Rego.RootKey:=HKEY_USERS;
IF Rego.OpenKey(‘.DEFAULTSoftwareAngelSoftDemo‘,False) then
begin
Form1.Caption:=‘软件已经注册‘;
Button1.Enabled:=false;
Label1.Caption:=rego.ReadString(‘Name‘);//读用户名.
Label2.Caption:=IntToStr(Rego.ReadInteger(‘Pass‘)); //读注册码.
rego.Free;
end
else Form1.Caption:=‘软件未注册,请注册‘;
end;
Function TForm1.Check():Boolean;//检查注册码是否正确.
var
Temp:pchar;
Name:string;
c:char;
I,Long,Pass:integer;
begin
Pass:=0;
Name:=edit1.Text;
long:=length(Name);
for I:=1 to Long do
begin
temp:=pchar(copy(Name,I,1));
c:=temp^;
Pass:=Pass+ord(c); //将用户名每个字符转换为ASCII码后相加.
end;
if StrToInt(Edit2.Text)=pass then
begin
Result:=True;
Pname:=Name;
Ppass:=Pass;
end
else Result:=False;
end;
procedure TForm1.Button1Click(Sender: Tobject);
begin
if Check then CreateReg
else ShowMessage(‘注册码不正确,无法注册‘);
end;
procedure TForm1.FormCreate(Sender: Tobject);
begin
CheckReg;
end;
end.
<注册器>
在DELPHI下新建一工程,放置Edit1,Edit2,Button1组件.具体代码如下:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;
type
TForm1 = class(Tform)
Button1: Tbutton;
Edit1: Tedit;
Edit2: Tedit;
procedure Button1Click(Sender: Tobject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.Button1Click(Sender: Tobject);
var
Temp:pchar;
Name:string;
c:char;
I,Long,Pass:integer;
begin
Pass:=0;
Name:=edit1.Text;
long:=length(Name);
for I:=1 to Long do
begin
temp:=pchar(copy(Name,I,1));
c:=temp^;
Pass:=Pass+ord(c);
end;
edit2.text:=IntToStr(pass);
end;
end.
从<注册器>中取得注册码,便可在<注册例程>中进行注册.原理是使用ORD函数取得用户名每单个字符的ASCII码值,并进行相加得到注册码.
function FilterNumber(keyval: char; me: TEdit; dot, Minus: string; ExtLen: integer): boolean;
var
s: string;
c: string;
p: Integer;
begin
result := false;
s := '0123456789';
c := keyval;
if (dot = '.') then
s := s + '.';
if (minus = '-') then
s := s + '-';
if (c = dot) and (TRIM(me.text) = '') then
Exit;
if (c = dot) and (Pos(dot, me.text) > 0) then
Exit;
if (c = dot) and (trim(me.text) = minus) then
Exit;
if (c = minus) and (Pos(minus, me.Text) > 0) then
Exit;
if (c = minus) and (pos(minus, me.Text) < 1) and (Me.SelStart > 0) then
Exit;
if (c = minus) and (trim(me.Text) = dot) then
Exit;
result := (keyval = chr(vk_return)) or (keyval = Chr(vk_tab))
or (keyval = chr(VK_DELETE)) or (keyval = chr(VK_BACK)) or (Pos(c, s) > 0);
p := Pos(dot, Me.Text + c);
if (p > 0) then
if (length(Me.text + c) - P) > ExtLen then
result := (false) or (keyval = chr(vk_return)) or (keyval = Chr(vk_tab))
or (keyval = chr(VK_DELETE)) or (keyval = chr(VK_BACK));
end;
procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char);
begin
if not filterNumber(key, Edit1, '.', '-', 6) then
key := #0;
end;
Top
//////如何用代码自动建ODBC
以下是在程序中动态创建ODBC的DSN数据源代码：
procedure TCreateODBCDSNfrm.CreateDSNBtnClick(Sender: TObject);
var
registerTemp : TRegistry;
bData : array[ 0..0 ] of byte;
begin
registerTemp := TRegistry.Create;
//建立一个Registry实例
with registerTemp do
begin
RootKey:=HKEY_LOCAL_MACHINE;
//设置根键值为HKEY_LOCAL_MACHINE
//找到Software/ODBC/ODBC.INI/ODBC Data Sources
if OpenKey('Software/ODBC/ODBC.INI
/ODBC Data Sources',True) then
begin //注册一个DSN名称
WriteString( 'MyAccess', 'Microsoft
Access Driver (*.mdb)' );
end
else
begin//创建键值失败
memo1.lines.add('增加ODBC数据源失败');
exit;
end;
CloseKey;
//找到或创建Software/ODBC/ODBC.INI
/MyAccess,写入DSN配置信息
if OpenKey('Software/ODBC/ODBC.INI
/MyAccess',True) then
begin
WriteString( 'DBQ', 'C:/inetpub/wwwroot
/test.mdb' );//数据库目录，连接您的数据库
WriteString( 'Description',
'我的新数据源' );//数据源描述
WriteString( 'Driver', 'C:/PWIN98/SYSTEM/
odbcjt32.dll' );//驱动程序DLL文件
WriteInteger( 'DriverId', 25 );
//驱动程序标识
WriteString( 'FIL', 'Ms Access;' );
//Filter依据
WriteInteger( 'SafeTransaction', 0 );
//支持的事务操作数目
WriteString( 'UID', '' );//用户名称
bData[0] := 0;
WriteBinaryData( 'Exclusive', bData, 1 );
//非独占方式
WriteBinaryData( 'ReadOnly', bData, 1 );
//非只读方式
end
else//创建键值失败
begin
memo1.lines.add('增加ODBC数据源失败');
exit;
end;
CloseKey;
//找到或创建Software/ODBC/ODBC.INI
/MyAccess/Engines/Jet
//写入DSN数据库引擎配置信息
if OpenKey('Software/ODBC/ODBC.INI
/MyAccess/Engines/Jet',True) then
begin
WriteString( 'ImplicitCommitSync', 'Yes' );
WriteInteger( 'MaxBufferSize', 512 );//缓冲区大小
WriteInteger( 'PageTimeout', 10 );//页超时
WriteInteger( 'Threads', 3 );//支持的线程数目
WriteString( 'UserCommitSync', 'Yes' );
end
else//创建键值失败
begin
memo1.lines.add('增加ODBC数据源失败');
exit;
end;
CloseKey;
memo1.lines.add('增加新ODBC数据源成功');
Free;
end;
end;
一个管理最近使用过的文件的类：
{-----------------------------------------------------------------------------
Unit Name: RcntFileMgr
Author: tony
Purpose: Manager the recent file list.
History: 2004.06.08 create
-----------------------------------------------------------------------------}
unit RcntFileMgr;
interface
uses
Classes, SysUtils, Inifiles;
type
TRecentFileChangedEvent = procedure(Sender:TObject) of object;
TRecentFileManager=class(TObject)
private
FRecentFileList:TStringList;
FMaxRecentCount:Integer;
FOnRecentFileChanged:TRecentFileChangedEvent;
protected
function GetRecentFileCount():Integer;
function GetRecentFile(Index:Integer):String;
procedure LoadFromConfigFile();
procedure SaveToConfigFile();
public
constructor Create();
destructor Destroy();override;
procedure AddRecentFile(const AFileName:String);
property RecentFileCount:Integer read GetRecentFileCount;
property RecentFile[Index:Integer]:String read GetRecentFile;
property OnRecentFileChanged:TRecentFileChangedEvent read FOnRecentFileChanged write FOnRecentFileChanged;
end;
implementation
{ TRecentFileManager }
function TRecentFileManager.GetRecentFileCount():Integer;
begin
Result:=FRecentFileList.Count;
end;
function TRecentFileManager.GetRecentFile(Index:Integer):String;
begin
Result:=FRecentFileList.Strings[Index];
end;
procedure TRecentFileManager.LoadFromConfigFile();
var
Ini:TInifile;
KeyList:TStringList;
I:Integer;
begin
Ini:=TInifile.Create(ExtractFilePath(ParamStr(0))+'config.ini');
KeyList:=TStringList.Create();
try
Ini.ReadSection('RecentFile',KeyList);
for I:=0 to KeyList.Count-1 do begin
FRecentFileList.Add(Ini.ReadString('RecentFile',KeyList.Strings[I],''));
end;
if Assigned(FOnRecentFileChanged) then begin
FOnRecentFileChanged(self);
end;
finally
Ini.Free;
KeyList.Free;
end;
end;
procedure TRecentFileManager.SaveToConfigFile();
var
Ini:TInifile;
I:Integer;
begin
Ini:=TInifile.Create(ExtractFilePath(ParamStr(0))+'config.ini');
try
Ini.EraseSection('RecentFile');
for I:=0 to FRecentFileList.Count-1 do begin
Ini.WriteString('RecentFile','Recent'+IntToStr(I),FRecentFileList.Strings[I]);
end;
finally
Ini.Free;
end;
end;
constructor TRecentFileManager.Create();
begin
inherited Create();
FRecentFileList:=TStringList.Create();
FMaxRecentCount:=5;
LoadFromConfigFile();
end;
destructor TRecentFileManager.Destroy();
begin
if Assigned(FRecentFileList) then begin
try
SaveToConfigFile();
except
//ignore any exceptions
end;
FreeAndNil(FRecentFileList);
end;
inherited Destroy();
end;
procedure TRecentFileManager.AddRecentFile(const AFileName:String);
var
RecentIndex:Integer;
begin
RecentIndex:=FRecentFileList.IndexOf(AFileName);
if RecentIndex>=0 then begin
FRecentFileList.Delete(RecentIndex);
end;
FRecentFileList.Insert(0,AFileName);
while FRecentFileList.Count>FMaxRecentCount do begin
FRecentFileList.Delete(FRecentFileList.Count-1);
end;
if Assigned(FOnRecentFileChanged) then begin
FOnRecentFileChanged(self);
end;
end;
end.
Top
9楼 tonylk (=www.tonixsoft.com=) 回复于 2004-07-20 15:55:46 得分 0
一个SDI类型的文件管理器，可以管理新建，保存，另存为，以及关闭时提示保存等功能：
unit FileMgr;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Forms, Controls, Dialogs,
QuickWizardFrm, TLMObject;
type
TNewFileEvent = procedure (Sender:TObject;var Successful:Boolean) of object;
TStartWizardEvent = procedure (Sender:TObject;Info:TQuickWizardInfo;var Successful:Boolean) of object;
TOpenFileEvent = procedure (Sender:TObject;const FileName:String;var
Successful:Boolean) of object;
TSaveFileEvent = procedure (Sender:TObject;const FileName:String;var
Successful:Boolean) of object;
TCloseFileEvent = procedure (Sender:TObject;var Successful:Boolean) of object;
TFileNameChangedEvent = procedure (Sender:TObject;const FileName:String) of
object;
TFileManager = class (TObject)
private
FFileName: String;
FIsNewFile:Boolean;
FModified: Boolean;
FFileFilter:String;
FDefaultExt:String;
FtlmObject:TtlmObject;
FOnCloseFile: TCloseFileEvent;
FOnFileNameChanged: TFileNameChangedEvent;
FOnNewFile: TNewFileEvent;
FOnStartWizard: TStartWizardEvent;
FOnOpenFile: TOpenFileEvent;
FOnSaveFile: TSaveFileEvent;
protected
procedure SetModified(AValue: Boolean);
public
constructor Create;
destructor Destroy; override;
function DoCloseFile: Boolean;
function DoNewFile: Boolean;
function DoStartWizard:Boolean;
function DoOpenFile: Boolean;overload;
function DoOpenFile(const AFileName:String):Boolean;overload;
function DoSaveAsFile: Boolean;
function DoSaveFile: Boolean;
property FileName: string read FFileName;
property Modified: Boolean read FModified write SetModified;
property FileFilter:String read FFileFilter write FFileFilter;
property DefaultExt:String read FDefaultExt write FDefaultExt;
property OnCloseFile: TCloseFileEvent read FOnCloseFile write FOnCloseFile;
property OnFileNameChanged: TFileNameChangedEvent read FOnFileNameChanged
write FOnFileNameChanged;
property OnNewFile: TNewFileEvent read FOnNewFile write FOnNewFile;
property OnStartWizard: TStartWizardEvent read FOnStartWizard write FOnStartWizard;
property OnOpenFile: TOpenFileEvent read FOnOpenFile write FOnOpenFile;
property OnSaveFile: TSaveFileEvent read FOnSaveFile write FOnSaveFile;
end;
implementation
{
********************************* TFileManager *********************************
}
constructor TFileManager.Create;
begin
inherited Create();
FtlmObject:=TtlmObject.Create(self);
FFileName:='';
FIsNewFile:=true;
Modified:=false;
if Assigned(FOnFileNameChanged) then begin
FOnFileNameChanged(self,FFileName);
end;
end;
destructor TFileManager.Destroy;
begin
if Assigned(FtlmObject) then begin
FreeAndNil(FtlmObject);
end;
inherited Destroy();
end;
function TFileManager.DoCloseFile: Boolean;
var
MsgResult: TModalResult;
Succ: Boolean;
begin
if FModified then begin
Result:=false;
MsgResult:=MessageBox(Application.Handle,
PChar(FtlmObject.Translate('FileModified','File ''%s'' had been modified, do you want to save it?',[FFileName])),
pchar(Application.Title),MB_ICONQUESTION or MB_YESNOCANCEL);
if MsgResult=mrYES then begin
if not DoSaveFile() then
exit;
end
else if MsgResult=mrCancel then begin
exit;
end;
if Assigned(FOnCloseFile) then begin
Succ:=false;
FOnCloseFile(self,Succ);
Result:=Succ;
if Result then begin
FFileName:='';
FIsNewFile:=false;
FModified:=false;
if Assigned(FOnFileNameChanged) then begin
FOnFileNameChanged(self,FFileName);
end;
end;
end;
end
else begin
if Assigned(FOnCloseFile) then begin
Succ:=false;
FOnCloseFile(self,Succ);
Result:=Succ;
if Result then begin
FFileName:='';
FIsNewFile:=false;
FModified:=false;
if Assigned(FOnFileNameChanged) then begin
FOnFileNameChanged(self,FFileName);
end;
end;
end;
Result:=true;
end;
end;
function TFileManager.DoNewFile: Boolean;
var
Succ: Boolean;
begin
Result:=false;
if not DoCloseFile() then
exit;
if Assigned(FOnNewFile) then begin
Succ:=false;
FOnNewFile(self,Succ);
Result:=Succ;
if Result then begin
FFileName:=FtlmObject.Translate('NewAlbum','New Album');
FIsNewFile:=true;
FModified:=false;
if Assigned(FOnFileNameChanged) then begin
FOnFileNameChanged(self,FFileName);
end;
end;
end;
end;
function TFileManager.DoStartWizard:Boolean;
var
Succ:Boolean;
Info:TQuickWizardInfo;
begin
Result:=false;
if Assigned(FOnStartWizard) then begin
Info.ImageList:=TStringList.Create();
Info.FileName:=FtlmObject.Translate('NewAlbum','New Album');
Info.CopyImage:=false;
Info.CreateContent:=true;
try
if not ShowQuickWizardForm(nil,Info) then
exit;
if not DoCloseFile() then
exit;
Succ:=false;
FOnStartWizard(self,Info,Succ);
Result:=Succ;
if Result then begin
FFileName:=Info.FileName;
FIsNewFile:=true;
FModified:=true;
if Assigned(FOnFileNameChanged) then begin
FOnFileNameChanged(self,FFileName + ' *');
end;
end
else begin
DoNewFile();
end;
finally
Info.ImageList.Free;
end;
end;
end;
function TFileManager.DoOpenFile: Boolean;
var
Succ: Boolean;
OpenDialog: TOpenDialog;
FileNameTmp: string;
begin
Result:=false;
if Assigned(FOnOpenFile) then begin
OpenDialog:=TOpenDialog.Create(nil);
try
OpenDialog.Filter:=FFileFilter;
OpenDialog.FilterIndex:=0;
OpenDialog.DefaultExt:=FDefaultExt;
if OpenDialog.Execute then begin
FileNameTmp:=OpenDialog.FileName;
if (CompareText(FileNameTmp,FFileName)=0) and (not FIsNewFile) then begin //if the file already opened
if MessageBox(Application.Handle,PChar(FtlmObject.Translate('FileAlreadyOpened','This file already opened, do you want to open it anyway?')),
PChar(Application.Title),MB_ICONQUESTION+MB_YESNO)=mrNo then begin
exit;
end;
end;
if not DoCloseFile() then
exit;
Succ:=false;
FOnOpenFile(self,FileNameTmp,Succ);
Result:=Succ;
if Result then begin
FFileName:=FileNameTmp;
FIsNewFile:=false;
FModified:=false;
if Assigned(FOnFileNameChanged) then begin
FOnFileNameChanged(self,FFileName);
end;
end
else begin
DoNewFile();
end;
end;
finally
OpenDialog.Free;
end;
end;
end;
function TFileManager.DoOpenFile(const AFileName:String):Boolean;
var
Succ:Boolean;
begin
Result:=false;
if Assigned(FOnOpenFile) then begin
if (CompareText(AFileName,FFileName)=0) and (not FIsNewFile) then begin //if the file already opened
if MessageBox(Application.Handle,PChar(FtlmObject.Translate('FileAlreadyOpened','This file already opened, do you want to open it anyway?')),
PChar(Application.Title),MB_ICONQUESTION+MB_YESNO)=mrNo then begin
exit;
end;
end;
if not DoCloseFile() then
exit;
Succ:=false;
FOnOpenFile(self,AFileName,Succ);
Result:=Succ;
if Result then begin
FFileName:=AFileName;
FIsNewFile:=false;
FModified:=false;
if Assigned(FOnFileNameChanged) then begin
FOnFileNameChanged(self,FFileName);
end;
end
else begin
DoNewFile();
end;
end;
end;
function TFileManager.DoSaveAsFile: Boolean;
var
Succ: Boolean;
SaveDialog: TSaveDialog;
FileNameTmp: string;
begin
Result:=false;
if Assigned(FOnSaveFile) then begin
SaveDialog:=TSaveDialog.Create(nil);
try
SaveDialog.Filter:=FFileFilter;
SaveDialog.FilterIndex:=0;
SaveDialog.DefaultExt:=FDefaultExt;
SaveDialog.FileName:=FFileName;
SaveDialog.Options:=SaveDialog.Options+[ofOverwritePrompt];
if SaveDialog.Execute then begin
FileNameTmp:=SaveDialog.FileName;
Succ:=false;
FOnSaveFile(self,FileNameTmp,Succ);
Result:=Succ;
if Result then begin
FFileName:=FileNameTmp;
FIsNewFile:=false;
FModified:=false;
if Assigned(FOnFileNameChanged) then begin
FOnFileNameChanged(self,FFileName);
end;
end;
end;
finally
SaveDialog.Free;
end;
end;
end;
function TFileManager.DoSaveFile: Boolean;
var
Succ: Boolean;
begin
Result:=false;
if (FileExists(FFileName)) and (not FIsNewFile) then begin
if Assigned(FOnSaveFile) then begin
Succ:=false;
FOnSaveFile(self,FFileName,Succ);
Result:=Succ;
if Result then begin
FIsNewFile:=false;
FModified:=false;
if Assigned(FOnFileNameChanged) then begin
FOnFileNameChanged(self,FFileName);
end;
end;
end;
end
else begin
Result:=DoSaveAsFile();
end;
end;
procedure TFileManager.SetModified(AValue: Boolean);
begin
if FModified<>AValue then begin
if Assigned(FOnFileNameChanged) then begin
if AValue then begin
FOnFileNameChanged(self,FFileName+' *');
end
else begin
FOnFileNameChanged(self,FFileName);
end;
end;
FModified:=AValue;
end;
end;
end.
一段支持Splash启动窗体，以及在Splash窗体中显示启动的进度：
{-----------------------------------------------------------------------------
Unit Name: AppLdr
Author: tony
Purpose: Application Loader
History: 2004.07.08 create
-----------------------------------------------------------------------------}
unit AppLdr;
interface
uses
Windows, Messages, SysUtils, Classes, Controls, Forms, SplashForm,
TLMIniFilter, ActiveX, Common;
type
TAppLoader = class (TObject)
private
FSplashForm: TfrmSplash;
FtlmIniFilter:TtlmIniFilter;
procedure OnAppLoading(ASender:TObject;AEvent:String;ADelay:Integer=50);
public
constructor Create();
destructor Destroy();override;
function DoLoad: Boolean;
end;
var
GAppLoader:TAppLoader;
implementation
uses
SkinMdl, ConfigMgr, CommMgr, ICDeviceMgr, HdgClient, C1;
{
********************************** TAppLoader **********************************
}
constructor TAppLoader.Create();
begin
inherited Create();
FtlmIniFilter:=TtlmIniFilter.Create(Application);
FtlmIniFilter.LanguageFiles.Add('HDG2.chs');
FtlmIniFilter.LanguageExt:='.chs';
FtlmIniFilter.Active:=true;
end;
destructor TAppLoader.Destroy();
begin
if Assigned(frmC1) then begin
GCommManager.EndListen();
FreeAndNil(frmC1);
end;
if Assigned(GHdgClient) then begin
FreeAndNil(GHdgClient);
end;
if Assigned(GCommManager) then begin
FreeAndNil(GCommManager);
end;
if Assigned(GICDevice) then begin
FreeAndNil(GICDevice);
end;
if Assigned(GSkinModule) then begin
FreeAndNil(GSkinModule);
end;
if Assigned(GConfigManager) then begin
FreeAndNil(GConfigManager);
end;
if Assigned(FtlmIniFilter) then begin
FreeAndNil(FtlmIniFilter);
end;
inherited Destroy();
end;
function TAppLoader.DoLoad: Boolean;
begin
Result:=false;
Application.Title:='HDG2';
FSplashForm:=TfrmSplash.Create(nil);
try
try
FSplashForm.Show;
OnAppLoading(nil,'Starting...');
Sleep(200);
GConfigManager:=TConfigManager.Create();
GSkinModule:=TSkinModule.Create(nil);
GICDevice:=TICDeviceDecorator.Create();
GICDevice.OnAppLoading:=OnAppLoading;
GICDevice.Initialize();
GICDevice.OnAppLoading:=nil;
GCommManager:=TCommManagerDecorator.Create(nil);
GCommManager.ConfigManager:=GConfigManager;
GCommManager.ICDevice:=GICDevice;
GCommManager.OnAppLoading:=OnAppLoading;
GCommManager.Initialize(true,false,false);
GCommManager.OnAppLoading:=nil;
GHdgClient:=THdgClient.Create();
GHdgClient.OnAppLoading:=OnAppLoading;
GHdgClient.Initialize();
GHdgClient.OnAppLoading:=nil;
OnAppLoading(nil,'Ending...');
Screen.Cursors[crNo]:=LoadCursor(hInstance,'None');
Application.CreateForm(TfrmC1, frmC1);
GCommManager.BeginListen(frmC1);
frmC1.SysCaption:=GConfigManager.SysCaption;
{$IFNDEF HDGCLIENT}
frmC1.SysLedCaption:=GConfigManager.SysLedCaption;
{$ENDIF}
Result:=true;
except
on E:Exception do begin
MessageBox(Application.Handle,PChar(E.ClassName+':'+#13+#10+E.Message),
PChar(Application.Title),MB_ICONERROR);
end;
end;
finally
FreeAndNil(FSplashForm);
end;
end;
procedure TAppLoader.OnAppLoading(ASender:TObject;AEvent:String;
ADelay:Integer);
begin
if Assigned(FSplashForm) then begin
if Assigned(ASender) then begin
FSplashForm.lbl1.Caption:=ASender.ClassName+': '+AEvent;
end
else begin
FSplashForm.lbl1.Caption:=AEvent;
end;
FSplashForm.Update;
if ADelay>0 then
Sleep(ADelay);
end;
end;
end.
工程的dpr中这样用：
begin
Application.Initialize;
GAppLoader:=TAppLoader.Create();
try
if GAppLoader.DoLoad() then begin
Application.Run;
end;
finally
GAppLoader.Free;
end;
end.
获得Memo、RichEdit的光标位置：
--------------------------------------------------------------------------------
procedure TForm1.Button1Click(Sender: TObject);
var Row, Col : integer;
begin
Row := SendMessage(Memo1.Handle, EM_LINEFROMCHAR, Memo1.SelStart, 0);
Col := CustEdit.SelStart - SendMessage(Memo1.Handle, EM_LINEINDEX, -1, 0);
Edit1.Text:='行,列:'+IntToStr(Row)+','+IntToStr(Col);
end;
Top
一个可以为其父控件提供从浏览器拖入文件功能的类：
{-----------------------------------------------------------------------------
Unit Name: ImgDropper
Author: tony
Purpose: provide the function for drop image from explorer.
this class should be created as an member of TPhotoPage.
History: 2004.01.31 create
-----------------------------------------------------------------------------}
unit ImgDropper;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Controls, Graphics,
Forms, ShellAPI, TLMObject;
type
TImageDropper = class(TObject)
private
FParent:TWinControl;
FOldWindowProc:TWndMethod;
FtlmObject:TtlmObject;
protected
procedure ParentWindowProc(var Message: TMessage);
public
constructor Create(AParent:TWinControl);
destructor Destroy();override;
end;
implementation
uses
AlbumMgr, PhotoPge, ImgDropFrm, ImageLdr;
{ TImageDropper }
procedure TImageDropper.ParentWindowProc(var Message: TMessage);
procedure EnumDropFiles(AFileList:TStringList);
var
pcFileName:PChar;
i,iSize,iFileCount:Integer;
begin
try
pcFileName:='';
iFileCount:=DragQueryFile(Message.WParam,$FFFFFFFF,pcFileName,MAX_PATH);
for I:=0 to iFileCount-1 do begin
iSize:=DragQueryFile(Message.WParam,i,nil,0)+1;
pcFileName:=StrAlloc(iSize);
DragQueryFile(Message.WParam,i,pcFileName,iSize);
AFileList.Add(pcFileName);
StrDispose(pcFileName);
end;
finally
DragFinish(Message.WParam);
end;
end;
var
FileList:TStringList;
RdPage:TRdPage;
DropInfo:TImgDropInfo;
I:Integer;
NewRdPage:TRdPage;
ImageLoader:TImageLoader;
Bmp:TBitmap;
begin
if Message.Msg=WM_DROPFILES then begin
FileList:=TStringList.Create();
try
if not (FParent is TPhotoPage) then
exit;
RdPage:=TPhotoPage(FParent).RdPage;
if not Assigned(RdPage) then
exit;
EnumDropFiles(FileList);
if FileList.Count=1 then begin //only dropped one image
RdPage.DoAddImageItem(FileList.Strings[0]);
end
else begin //dropped several images
DropInfo.PlaceEachPage:=true;
if not ShowImgDropForm(nil,DropInfo) then begin
exit;
end;
if DropInfo.PlaceEachPage then begin
ImageLoader:=TImageLoader.Create();
Bmp:=TBitmap.Create();
try
for I:=0 to FileList.Count-1 do begin
NewRdPage:=RdPage.Parent.DoInsertPage(RdPage.PageIndex+1);
if not Assigned(NewRdPage) then begin
break;
end;
ImageLoader.LoadFromFile(FileList.Strings[I],Bmp);
NewRdPage.DoAddImageItem(FileList.Strings[I],Bmp.Width,Bmp.Height);
end;
finally
ImageLoader.Free;
Bmp.Free;
end;
end
else begin
for I:=0 to FileList.Count-1 do begin
RdPage.DoAddImageItem(FileList.Strings[I]);
end;
end;
MessageBox(FParent.Handle,PChar(FtlmObject.Translate('ImagesAdded','%d images had been added!',[FileList.Count])),PChar(Application.Title),MB_ICONINFORMATION);
end;
finally
FileList.Free;
end;
end
else begin
FOldWindowProc(Message);
end;
end;
constructor TImageDropper.Create(AParent:TWinControl);
begin
inherited Create();
FParent:=AParent;
DragAcceptFiles(FParent.Handle,true);
FOldWindowProc:=FParent.WindowProc;
FParent.WindowProc:=ParentWindowProc;
FtlmObject:=TtlmObject.Create(self);
end;
destructor TImageDropper.Destroy();
begin
if Assigned(FtlmObject) then begin
FreeAndNil(FtlmObject);
end;
DragAcceptFiles(FParent.Handle,false);
FParent.WindowProc:=FOldWindowProc;
inherited Destroy();
end;
end.
获得Memo、RichEdit的光标位置：
--------------------------------------------------------------------------------
procedure TForm1.Button1Click(Sender: TObject);
var Row, Col : integer;
begin
Row := SendMessage(Memo1.Handle, EM_LINEFROMCHAR, Memo1.SelStart, 0);
Col := CustEdit.SelStart - SendMessage(Memo1.Handle, EM_LINEINDEX, -1, 0);
Edit1.Text:='行,列:'+IntToStr(Row)+','+IntToStr(Col);
end;
Top
16楼 GreatSuperYoyoNC (ExSystem|麻烦结帖[-_-]) 回复于 2004-07-20 16:11:30 得分 0
//--[Yoyoworks]----------------------------------------------------------------
//工程名称：prjPowerFlashPlayer
//软件名称：iPowerFlashPlayer
//单元作者：许子健
//开始日期：2004年03月14日，14:31:16
//单元功能：用于音量调整的类。
//-----------------------------------------------------------[SHANGHAi|CHiNA]--
Unit untTVolume;
Interface
Uses
MMSystem, SysUtils;
Type
TVolume = Class(TObject)
Private
FVolume: LongInt; //存储音量。
FIsMute: Boolean; //存储静音值。
Procedure SetLeftVolume(Volume: Integer); //设置左声道的音量。
Function GetLeftVolume: Integer; //获得左声道的音量。
Procedure SetRightVolume(Volume: Integer); //设置右声道的音量。
Function GetRightVolume: Integer; //获得右声道的音量。
Procedure SetIsMute(IsMute: Boolean); //设置是否静音。
Public
Constructor Create;
Destructor Destroy; Override;
Published
Property LeftVolume: Integer Read GetLeftVolume Write SetLeftVolume;
Property RightVolume: Integer Read GetRightVolume Write SetRightVolume;
Property Mute: Boolean Read FIsMute Write SetIsMute;
End;
Implementation
// -----------------------------------------------------------------------------
// 过程名： TVolume.Create
// 参数： 无
// 返回值： 无
// -----------------------------------------------------------------------------
Constructor TVolume.Create;
Begin
Inherited Create;
FVolume := 0;
FIsMute := False;
//初始化变量
waveOutGetVolume(0, @FVolume); //得到现在音量
End;
// -----------------------------------------------------------------------------
// 过程名： TVolume.Destroy
// 参数： 无
// 返回值： 无
// -----------------------------------------------------------------------------
Destructor TVolume.Destroy;
Begin
Inherited Destroy;
End;
// -----------------------------------------------------------------------------
// 过程名： TVolume.SetLeftVolume
// 参数： Volume: Integer
// 返回值： 无
// -----------------------------------------------------------------------------
Procedure TVolume.SetLeftVolume(Volume: Integer);
Begin
If (Volume < 0) Or (Volume > 255) Then
Raise Exception.Create('Range error of the left channel [0 to 255].');
//如果“Volume”参数不在0至255的范围里，则抛出异常。
If FIsMute = False Then
Begin
waveOutGetVolume(0, @FVolume);
//@示指向变量Volume的指针（32位），调用此函数的用意就是得到右声道的值，做到在调节左声道的时候，不改变右声道。
FVolume := FVolume And $FFFF0000 Or (Volume Shl 8); //数字前加$表示是十六进制
waveOutSetVolume(0, FVolume);
End
//如果不是静音状态，则改变音量；
Else
FVolume := FVolume And $FFFF0000 Or (Volume Shl 8);
//否则，只改变变量。
End;
// -----------------------------------------------------------------------------
// 过程名： TVolume.SetRightVolume
// 参数： Volume: Integer
// 返回值： 无
// -----------------------------------------------------------------------------
Procedure TVolume.SetRightVolume(Volume: Integer);
Begin
If (Volume < 0) Or (Volume > 255) Then
Raise Exception.Create('Range error of the right channel [0 to 255].');
If FIsMute = False Then
Begin
waveOutGetVolume(0, @FVolume);
FVolume := FVolume And $0000FFFF Or (Volume Shl 24);
waveOutSetVolume(0, FVolume);
End
Else
FVolume := FVolume And $0000FFFF Or (Volume Shl 24);
End;
// -----------------------------------------------------------------------------
// 过程名： TVolume.SetIsMute
// 参数： IsMute: Boolean
// 返回值： 无
// -----------------------------------------------------------------------------
Procedure TVolume.SetIsMute(IsMute: Boolean);
Begin
FIsMute := IsMute;
If FIsMute = True Then
waveOutSetVolume(0, 0)
Else
waveOutSetVolume(0, FVolume);
End;
// -----------------------------------------------------------------------------
// 函数名： TVolume.GetLeftVolume
// 参数： 无
// 返回值： Integer
// -----------------------------------------------------------------------------
Function TVolume.GetLeftVolume: Integer;
Begin
If FIsMute = False Then
waveOutGetVolume(0, @FVolume); //得到现在音量
Result := Hi(FVolume); //转换成数字
End;
// -----------------------------------------------------------------------------
// 函数名： TVolume.GetRightVolume
// 参数： 无
// 返回值： Integer
// -----------------------------------------------------------------------------
Function TVolume.GetRightVolume: Integer;
Begin
If FIsMute = False Then
waveOutGetVolume(0, @FVolume); //得到现在音量
Result := Hi(FVolume Shr 16); //转换成数字
End;
End.
点击DBGrid的Title对查询结果排序 关键词:DBGrid 排序
欲
客服电话
APP下载
官方微信
请发表评论