借鉴 学习 DELPHI 通用函数 哈哈
[转]关于Delphi通用涵数
http://m.blog.csdn.net/blog/dragonjiang5460/1196927
2006-9-8阅读2016 评论0
DELPHI程序注册码设计（转载）
思路是这样的:程序运行时先检测注册表,如果找到注册项,则表明已经注册,如果没有找到注册项,则提示要求注册.
<注册例程>
在DELPHI下新建一工程,放置Edit1,Edit2,Label1,Label2,Button1组件.具体代码如下:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls,Registry;//在此加上Registry以便调用注册表.
type
TForm1 = class(Tform)
Button1: Tbutton;
Edit1: Tedit;
Edit2: Tedit;
Label1: Tlabel;
Label2: Tlabel;
procedure Button1Click(Sender: Tobject);
procedure FormCreate(Sender: Tobject);
private
Function Check():Boolean;
Procedure CheckReg();
Procedure CreateReg();
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
Pname:string; //全局变量,存放用户名和注册码.
Ppass:integer;
implementation
{$R *.DFM}
Procedure TForm1.CreateReg();//创建用户信息.
var Rego:Tregistry;
begin
Rego:=Tregistry.Create;
Rego.RootKey:=HKEY_USERS;
rego.OpenKey(‘.DEFAULTSoftwareAngelSoftDemo‘,True);//键名为AngelSoftDemo,可自行修改.
Rego.WriteString(‘Name‘,Pname);//写入用户名.
Rego.WriteInteger(‘Pass‘,Ppass);//写入注册码.
Rego.Free;
ShowMessage(‘程序已经注册,谢谢!‘);
CheckReg; //刷新.
end;
Procedure TForm1.CheckReg();//检查程序是否在注册表中注册.
var Rego:Tregistry;
begin
Rego:=Tregistry.Create;
Rego.RootKey:=HKEY_USERS;
IF Rego.OpenKey(‘.DEFAULTSoftwareAngelSoftDemo‘,False) then
begin
Form1.Caption:=‘软件已经注册‘;
Button1.Enabled:=false;
Label1.Caption:=rego.ReadString(‘Name‘);//读用户名.
Label2.Caption:=IntToStr(Rego.ReadInteger(‘Pass‘)); //读注册码.
rego.Free;
end
else Form1.Caption:=‘软件未注册,请注册‘;
end;
Function TForm1.Check():Boolean;//检查注册码是否正确.
var
Temp:pchar;
Name:string;
c:char;
I,Long,Pass:integer;
begin
Pass:=0;
Name:=edit1.Text;
long:=length(Name);
for I:=1 to Long do
begin
temp:=pchar(copy(Name,I,1));
c:=temp^;
Pass:=Pass+ord(c); //将用户名每个字符转换为ASCII码后相加.
end;
if StrToInt(Edit2.Text)=pass then
begin
Result:=True;
Pname:=Name;
Ppass:=Pass;
end
else Result:=False;
end;
procedure TForm1.Button1Click(Sender: Tobject);
begin
if Check then CreateReg
else ShowMessage(‘注册码不正确,无法注册‘);
end;
procedure TForm1.FormCreate(Sender: Tobject);
begin
CheckReg;
end;
end.
<注册器>
在DELPHI下新建一工程,放置Edit1,Edit2,Button1组件.具体代码如下:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;
type
TForm1 = class(Tform)
Button1: Tbutton;
Edit1: Tedit;
Edit2: Tedit;
procedure Button1Click(Sender: Tobject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.Button1Click(Sender: Tobject);
var
Temp:pchar;
Name:string;
c:char;
I,Long,Pass:integer;
begin
Pass:=0;
Name:=edit1.Text;
long:=length(Name);
for I:=1 to Long do
begin
temp:=pchar(copy(Name,I,1));
c:=temp^;
Pass:=Pass+ord(c);
end;
edit2.text:=IntToStr(pass);
end;
end.
从<注册器>中取得注册码,便可在<注册例程>中进行注册.原理是使用ORD函数取得用户名每单个字符的ASCII码值,并进行相加得到注册码.
function FilterNumber(keyval: char; me: TEdit; dot, Minus: string; ExtLen: integer): boolean;
var
s: string;
c: string;
p: Integer;
begin
result := false;
s := '0123456789';
c := keyval;
if (dot = '.') then
s := s + '.';
if (minus = '-') then
s := s + '-';
if (c = dot) and (TRIM(me.text) = '') then
Exit;
if (c = dot) and (Pos(dot, me.text) > 0) then
Exit;
if (c = dot) and (trim(me.text) = minus) then
Exit;
if (c = minus) and (Pos(minus, me.Text) > 0) then
Exit;
if (c = minus) and (pos(minus, me.Text) < 1) and (Me.SelStart > 0) then
Exit;
if (c = minus) and (trim(me.Text) = dot) then
Exit;
result := (keyval = chr(vk_return)) or (keyval = Chr(vk_tab))
or (keyval = chr(VK_DELETE)) or (keyval = chr(VK_BACK)) or (Pos(c, s) > 0);
p := Pos(dot, Me.Text + c);
if (p > 0) then
if (length(Me.text + c) - P) > ExtLen then
result := (false) or (keyval = chr(vk_return)) or (keyval = Chr(vk_tab))
or (keyval = chr(VK_DELETE)) or (keyval = chr(VK_BACK));
end;
procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char);
begin
if not filterNumber(key, Edit1, '.', '-', 6) then
key := #0;
end;
Top
//////如何用代码自动建ODBC
以下是在程序中动态创建ODBC的DSN数据源代码：
procedure TCreateODBCDSNfrm.CreateDSNBtnClick(Sender: TObject);
var
registerTemp : TRegistry;
bData : array[ 0..0 ] of byte;
begin
registerTemp := TRegistry.Create;
//建立一个Registry实例
with registerTemp do
begin
RootKey:=HKEY_LOCAL_MACHINE;
//设置根键值为HKEY_LOCAL_MACHINE
//找到Software/ODBC/ODBC.INI/ODBC Data Sources
if OpenKey('Software/ODBC/ODBC.INI
/ODBC Data Sources',True) then
begin //注册一个DSN名称
WriteString( 'MyAccess', 'Microsoft
Access Driver (*.mdb)' );
end
else
begin//创建键值失败
memo1.lines.add('增加ODBC数据源失败');
exit;
end;
CloseKey;
//找到或创建Software/ODBC/ODBC.INI
/MyAccess,写入DSN配置信息
if OpenKey('Software/ODBC/ODBC.INI
/MyAccess',True) then
begin
WriteString( 'DBQ', 'C:/inetpub/wwwroot
/test.mdb' );//数据库目录，连接您的数据库
WriteString( 'Description',
'我的新数据源' );//数据源描述
WriteString( 'Driver', 'C:/PWIN98/SYSTEM/
odbcjt32.dll' );//驱动程序DLL文件
WriteInteger( 'DriverId', 25 );
//驱动程序标识
WriteString( 'FIL', 'Ms Access;' );
//Filter依据
WriteInteger( 'SafeTransaction', 0 );
//支持的事务操作数目
WriteString( 'UID', '' );//用户名称
bData[0] := 0;
WriteBinaryData( 'Exclusive', bData, 1 );
//非独占方式
WriteBinaryData( 'ReadOnly', bData, 1 );
//非只读方式
end
else//创建键值失败
begin
memo1.lines.add('增加ODBC数据源失败');
exit;
end;
CloseKey;
//找到或创建Software/ODBC/ODBC.INI
/MyAccess/Engines/Jet
//写入DSN数据库引擎配置信息
if OpenKey('Software/ODBC/ODBC.INI
/MyAccess/Engines/Jet',True) then
begin
WriteString( 'ImplicitCommitSync', 'Yes' );
WriteInteger( 'MaxBufferSize', 512 );//缓冲区大小
WriteInteger( 'PageTimeout', 10 );//页超时
WriteInteger( 'Threads', 3 );//支持的线程数目
WriteString( 'UserCommitSync', 'Yes' );
end
else//创建键值失败
begin
memo1.lines.add('增加ODBC数据源失败');
exit;
end;
CloseKey;
memo1.lines.add('增加新ODBC数据源成功');
Free;
end;
end;
一个管理最近使用过的文件的类：
{-----------------------------------------------------------------------------
Unit Name: RcntFileMgr
Author: tony
Purpose: Manager the recent file list.
History: 2004.06.08 create
-----------------------------------------------------------------------------}
unit RcntFileMgr;
interface
uses
Classes, SysUtils, Inifiles;
type
TRecentFileChangedEvent = procedure(Sender:TObject) of object;
TRecentFileManager=class(TObject)
private
FRecentFileList:TStringList;
FMaxRecentCount:Integer;
FOnRecentFileChanged:TRecentFileChangedEvent;
protected
function GetRecentFileCount():Integer;
function GetRecentFile(Index:Integer):String;
procedure LoadFromConfigFile();
procedure SaveToConfigFile();
public
constructor Create();
destructor Destroy();override;
procedure AddRecentFile(const AFileName:String);
property RecentFileCount:Integer read GetRecentFileCount;
property RecentFile[Index:Integer]:String read GetRecentFile;
property OnRecentFileChanged:TRecentFileChangedEvent read FOnRecentFileChanged write FOnRecentFileChanged;
end;
implementation
{ TRecentFileManager }
function TRecentFileManager.GetRecentFileCount():Integer;
begin
Result:=FRecentFileList.Count;
end;
function TRecentFileManager.GetRecentFile(Index:Integer):String;
begin
Result:=FRecentFileList.Strings[Index];
end;
procedure TRecentFileManager.LoadFromConfigFile();
var
Ini:TInifile;
KeyList:TStringList;
I:Integer;
begin
Ini:=TInifile.Create(ExtractFilePath(ParamStr(0))+'config.ini');
KeyList:=TStringList.Create();
try
Ini.ReadSection('RecentFile',KeyList);
for I:=0 to KeyList.Count-1 do begin
FRecentFileList.Add(Ini.ReadString('RecentFile',KeyList.Strings[I],''));
end;
if Assigned(FOnRecentFileChanged) then begin
FOnRecentFileChanged(self);
end;
finally
Ini.Free;
KeyList.Free;
end;
end;
procedure TRecentFileManager.SaveToConfigFile();
var
Ini:TInifile;
I:Integer;
begin
Ini:=TInifile.Create(ExtractFilePath(ParamStr(0))+'config.ini');
try
Ini.EraseSection('RecentFile');
for I:=0 to FRecentFileList.Count-1 do begin
Ini.WriteString('RecentFile','Recent'+IntToStr(I),FRecentFileList.Strings[I]);
end;
finally
Ini.Free;
end;
end;
constructor TRecentFileManager.Create();
begin
inherited Create();
FRecentFileList:=TStringList.Create();
FMaxRecentCount:=5;
LoadFromConfigFile();
end;
destructor TRecentFileManager.Destroy();
begin
if Assigned(FRecentFileList) then begin
try
SaveToConfigFile();
except
//ignore any exceptions
end;
FreeAndNil(FRecentFileList);
end;
inherited Destroy();
end;
procedure TRecentFileManager.AddRecentFile(const AFileName:String);
var
RecentIndex:Integer;
begin
RecentIndex:=FRecentFileList.IndexOf(AFileName);
if RecentIndex>=0 then begin
FRecentFileList.Delete(RecentIndex);
end;
FRecentFileList.Insert(0,AFileName);
while FRecentFileList.Count>FMaxRecentCount do begin
FRecentFileList.Delete(FRecentFileList.Count-1);
end;
if Assigned(FOnRecentFileChanged) then begin
FOnRecentFileChanged(self);
end;
end;
end.
Top
9楼 tonylk (=www.tonixsoft.com=) 回复于 2004-07-20 15:55:46 得分 0
一个SDI类型的文件管理器，可以管理新建，保存，另存为，以及关闭时提示保存等功能：
unit FileMgr;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Forms, Controls, Dialogs,
QuickWizardFrm, TLMObject;
type
TNewFileEvent = procedure (Sender:TObject;var Successful:Boolean) of object;
TStartWizardEvent = procedure (Sender:TObject;Info:TQuickWizardInfo;var Successful:Boolean) of object;
TOpenFileEvent = procedure (Sender:TObject;const FileName:String;var
Successful:Boolean) of object;
TSaveFileEvent = procedure (Sender:TObject;const FileName:String;var
Successful:Boolean) of object;
TCloseFileEvent = procedure (Sender:TObject;var Successful:Boolean) of object;
TFileNameChangedEvent = procedure (Sender:TObject;const FileName:String) of
object;
TFileManager = class (TObject)
private
FFileName: String;
FIsNewFile:Boolean;
FModified: Boolean;
FFileFilter:String;
FDefaultExt:String;
FtlmObject:TtlmObject;
FOnCloseFile: TCloseFileEvent;
FOnFileNameChanged: TFileNameChangedEvent;
FOnNewFile: TNewFileEvent;
FOnStartWizard: TStartWizardEvent;
FOnOpenFile: TOpenFileEvent;
FOnSaveFile: TSaveFileEvent;
protected
procedure SetModified(AValue: Boolean);
public
constructor Create;
destructor Destroy; override;
function DoCloseFile: Boolean;
function DoNewFile: Boolean;
function DoStartWizard:Boolean;
function DoOpenFile: Boolean;overload;
function DoOpenFile(const AFileName:String):Boolean;overload;
function DoSaveAsFile: Boolean;
function DoSaveFile: Boolean;
property FileName: string read FFileName;
property Modified: Boolean read FModified write SetModified;
property FileFilter:String read FFileFilter write FFileFilter;
property DefaultExt:String read FDefaultExt write FDefaultExt;
property OnCloseFile: TCloseFileEvent read FOnCloseFile write FOnCloseFile;
property OnFileNameChanged: TFileNameChangedEvent read FOnFileNameChanged
write FOnFileNameChanged;
property OnNewFile: TNewFileEvent read FOnNewFile write FOnNewFile;
property OnStartWizard: TStartWizardEvent read FOnStartWizard write FOnStartWizard;
property OnOpenFile: TOpenFileEvent read FOnOpenFile write FOnOpenFile;
property OnSaveFile: TSaveFileEvent read FOnSaveFile write FOnSaveFile;
end;
implementation
{
********************************* TFileManager *********************************
}
constructor TFileManager.Create;
begin
inherited Create();
FtlmObject:=TtlmObject.Create(self);
FFileName:='';
FIsNewFile:=true;
Modified:=false;
if Assigned(FOnFileNameChanged) then begin
FOnFileNameChanged(self,FFileName);
end;
end;
destructor TFileManager.Destroy;
begin
if Assigned(FtlmObject) then begin
FreeAndNil(FtlmObject);
end;
inherited Destroy();
end;
function TFileManager.DoCloseFile: Boolean;
var
MsgResult: TModalResult;
Succ: Boolean;
begin
if FModified then begin
Result:=false;
MsgResult:=MessageBox(Application.Handle,
PChar(FtlmObject.Translate('FileModified','File ''%s'' had been modified, do you want to save it?',[FFileName])),
pchar(Application.Title),MB_ICONQUESTION or MB_YESNOCANCEL);
if MsgResult=mrYES then begin
if not DoSaveFile() then
exit;
end
else if MsgResult=mrCancel then begin
exit;
end;
if Assigned(FOnCloseFile) then begin
Succ:=false;
FOnCloseFile(self,Succ);
Result:=Succ;
if Result then begin
FFileName:='';
FIsNewFile:=false;
FModified:=false;
if Assigned(FOnFileNameChanged) then begin
FOnFileNameChanged(self,FFileName);
end;
end;
end;
end
else begin
if Assigned(FOnCloseFile) then begin
Succ:=false;
FOnCloseFile(self,Succ);
Result:=Succ;
if Result then begin
FFileName:='';
FIsNewFile:=false;
FModified:=false;
if Assigned(FOnFileNameChanged) then begin
FOnFileNameChanged(self,FFileName);
end;
end;
end;
Result:=true;
end;
end;
function TFileManager.DoNewFile: Boolean;
var
Succ: Boolean;
begin
Result:=false;
if not DoCloseFile() then
exit;
if Assigned(FOnNewFile) then begin
Succ:=false;
FOnNewFile(self,Succ);
Result:=Succ;
if Result then begin
FFileName:=FtlmObject.Translate('NewAlbum','New Album');
FIsNewFile:=true;
FModified:=false;
if Assigned(FOnFileNameChanged) then begin
FOnFileNameChanged(self,FFileName);
end;
end;
end;
end;
function TFileManager.DoStartWizard:Boolean;
var
Succ:Boolean;
Info:TQuickWizardInfo;
begin
Result:=false;
if Assigned(FOnStartWizard) then begin
Info.ImageList:=TStringList.Create();
Info.FileName:=FtlmObject.Translate('NewAlbum','New Album');
Info.CopyImage:=false;
Info.CreateContent:=true;
try
if not ShowQuickWizardForm(nil,Info) then
exit;
if not DoCloseFile() then
exit;
Succ:=false;
FOnStartWizard(self,Info,Succ);
Result:=Succ;
if Result then begin
FFileName:=Info.FileName;
FIsNewFile:=true;
FModified:=true;
if Assigned(FOnFileNameChanged) then begin
FOnFileNameChanged(self,FFileName + ' *');
end;
end
else begin
DoNewFile();
end;
finally
Info.ImageList.Free;
end;
end;
end;
function TFileManager.DoOpenFile: Boolean;
var
Succ: Boolean;
OpenDialog: TOpenDialog;
FileNameTmp: string;
begin
Result:=false;
if Assigned(FOnOpenFile) then begin
OpenDialog:=TOpenDialog.Create(nil);
try
OpenDialog.Filter:=FFileFilter;
OpenDialog.FilterIndex:=0;
OpenDialog.DefaultExt:=FDefaultExt;
if OpenDialog.Execute then begin
FileNameTmp:=OpenDialog.FileName;
if (CompareText(FileNameTmp,FFileName)=0) and (not FIsNewFile) then begin //if the file already opened
if MessageBox(Application.Handle,PChar(FtlmObject.Translate('FileAlreadyOpened','This file already opened, do you want to open it anyway?')),
PChar(Application.Title),MB_ICONQUESTION+MB_YESNO)=mrNo then begin
exit;
end;
end;
if not DoCloseFile() then
exit;
Succ:=false;
FOnOpenFile(self,FileNameTmp,Succ);
Result:=Succ;
if Result then begin
FFileName:=FileNameTmp;
FIsNewFile:=false;
FModified:=false;
if Assigned(FOnFileNameChanged) then begin
FOnFileNameChanged(self,FFileName);
end;
end
else begin
DoNewFile();
end;
end;
finally
OpenDialog.Free;
end;
end;
end;
function TFileManager.DoOpenFile(const AFileName:String):Boolean;
var
Succ:Boolean;
begin
Result:=false;
if Assigned(FOnOpenFile) then begin
if (CompareText(AFileName,FFileName)=0) and (not FIsNewFile) then begin //if the file already opened
if MessageBox(Application.Handle,PChar(FtlmObject.Translate('FileAlreadyOpened','This file already opened, do you want to open it anyway?')),
PChar(Application.Title),MB_ICONQUESTION+MB_YESNO)=mrNo then begin
exit;
end;
end;
if not DoCloseFile() then
exit;
Succ:=false;
FOnOpenFile(self,AFileName,Succ);
Result:=Succ;
if Result then begin
FFileName:=AFileName;
FIsNewFile:=false;
FModified:=false;
if Assigned(FOnFileNameChanged) then begin
FOnFileNameChanged(self,FFileName);
end;
end
else begin
DoNewFile();
end;
end;
end;
function TFileManager.DoSaveAsFile: Boolean;
var
Succ: Boolean;
SaveDialog: TSaveDialog;
FileNameTmp: string;
begin
Result:=false;
if Assigned(FOnSaveFile) then begin
SaveDialog:=TSaveDialog.Create(nil);
try
SaveDialog.Filter:=FFileFilter;
SaveDialog.FilterIndex:=0;
SaveDialog.DefaultExt:=FDefaultExt;
SaveDialog.FileName:=FFileName;
SaveDialog.Options:=SaveDialog.Options+[ofOverwritePrompt];
if SaveDialog.Execute then begin
FileNameTmp:=SaveDialog.FileName;
Succ:=false;
FOnSaveFile(self,FileNameTmp,Succ);
Result:=Succ;
if Result then begin
FFileName:=FileNameTmp;
FIsNewFile:=false;
FModified:=false;
if Assigned(FOnFileNameChanged) then begin
FOnFileNameChanged(self,FFileName);
end;
end;
end;
finally
SaveDialog.Free;
end;
end;
end;
function TFileManager.DoSaveFile: Boolean;
var
Succ: Boolean;
begin
Result:=false;
if (FileExists(FFileName)) and (not FIsNewFile) then begin
if Assigned(FOnSaveFile) then begin
Succ:=false;
FOnSaveFile(self,FFileName,Succ);
Result:=Succ;
if Result then begin
FIsNewFile:=false;
FModified:=false;
if Assigned(FOnFileNameChanged) then begin
FOnFileNameChanged(self,FFileName);
end;
end;
end;
end
else begin
Result:=DoSaveAsFile();
end;
end;
procedure TFileManager.SetModified(AValue: Boolean);
begin
if FModified<>AValue then begin
if Assigned(FOnFileNameChanged) then begin
if AValue then begin
FOnFileNameChanged(self,FFileName+' *');
end
else begin
FOnFileNameChanged(self,FFileName);
end;
end;
FModified:=AValue;
end;
end;
end.
一段支持Splash启动窗体，以及在Splash窗体中显示启动的进度：
{-----------------------------------------------------------------------------
Unit Name: AppLdr
Author: tony
Purpose: Application Loader
History: 2004.07.08 create
-----------------------------------------------------------------------------}
unit AppLdr;
interface
uses
Windows, Messages, SysUtils, Classes, Controls, Forms, SplashForm,
TLMIniFilter, ActiveX, Common;
type
TAppLoader = class (TObject)
private
FSplashForm: TfrmSplash;
FtlmIniFilter:TtlmIniFilter;
procedure OnAppLoading(ASender:TObject;AEvent:String;ADelay:Integer=50);
public
constructor Create();
destructor Destroy();override;
function DoLoad: Boolean;
end;
var
GAppLoader:TAppLoader;
implementation
uses
SkinMdl, ConfigMgr, CommMgr, ICDeviceMgr, HdgClient, C1;
{
********************************** TAppLoader **********************************
}
constructor TAppLoader.Create();
begin
inherited Create();
FtlmIniFilter:=TtlmIniFilter.Create(Application);
FtlmIniFilter.LanguageFiles.Add('HDG2.chs');
FtlmIniFilter.LanguageExt:='.chs';
FtlmIniFilter.Active:=true;
end;
destructor TAppLoader.Destroy();
begin
if Assigned(frmC1) then begin
GCommManager.EndListen();
FreeAndNil(frmC1);
end;
if Assigned(GHdgClient) then begin
FreeAndNil(GHdgClient);
end;
if Assigned(GCommManager) then begin
FreeAndNil(GCommManager);
end;
if Assigned(GICDevice) then begin
FreeAndNil(GICDevice);
end;
if Assigned(GSkinModule) then begin
FreeAndNil(GSkinModule);
end;
if Assigned(GConfigManager) then begin
FreeAndNil(GConfigManager);
end;
if Assigned(FtlmIniFilter) then begin
FreeAndNil(FtlmIniFilter);
end;
inherited Destroy();
end;
function TAppLoader.DoLoad: Boolean;
begin
Result:=false;
Application.Title:='HDG2';
FSplashForm:=TfrmSplash.Create(nil);
try
try
FSplashForm.Show;
OnAppLoading(nil,'Starting...');
Sleep(200);
GConfigManager:=TConfigManager.Create();
GSkinModule:=TSkinModule.Create(nil);
GICDevice:=TICDeviceDecorator.Create();
GICDevice.OnAppLoading:=OnAppLoading;
GICDevice.Initialize();
GICDevice.OnAppLoading:=nil;
GCommManager:=TCommManagerDecorator.Create(nil);
GCommManager.ConfigManager:=GConfigManager;
GCommManager.ICDevice:=GICDevice;
GCommManager.OnAppLoading:=OnAppLoading;
GCommManager.Initialize(true,false,false);
GCommManager.OnAppLoading:=nil;
GHdgClient:=THdgClient.Create();
GHdgClient.OnAppLoading:=OnAppLoading;
GHdgClient.Initialize();
GHdgClient.OnAppLoading:=nil;
OnAppLoading(nil,'Ending...');
Screen.Cursors[crNo]:=LoadCursor(hInstance,'None');
Application.CreateForm(TfrmC1, frmC1);
GCommManager.BeginListen(frmC1);
frmC1.SysCaption:=GConfigManager.SysCaption;
{$IFNDEF HDGCLIENT}
frmC1.SysLedCaption:=GConfigManager.SysLedCaption;
{$ENDIF}
Result:=true;
except
on E:Exception do begin
MessageBox(Application.Handle,PChar(E.ClassName+':'+#13+#10+E.Message),
PChar(Application.Title),MB_ICONERROR);
end;
end;
finally
FreeAndNil(FSplashForm);
end;
end;
procedure TAppLoader.OnAppLoading(ASender:TObject;AEvent:String;
ADelay:Integer);
begin
if Assigned(FSplashForm) then begin
if Assigned(ASender) then begin
FSplashForm.lbl1.Caption:=ASender.ClassName+': '+AEvent;
end
else begin
FSplashForm.lbl1.Caption:=AEvent;
end;
FSplashForm.Update;
if ADelay>0 then
Sleep(ADelay);
end;
end;
end.
工程的dpr中这样用：
begin
Application.Initialize;
GAppLoader:=TAppLoader.Create();
try
if GAppLoader.DoLoad() then begin
Application.Run;
end;
finally
GAppLoader.Free;
end;
end.
获得Memo、RichEdit的光标位置：
--------------------------------------------------------------------------------
procedure TForm1.Button1Click(Sender: TObject);
var Row, Col : integer;
begin
Row := SendMessage(Memo1.Handle, EM_LINEFROMCHAR, Memo1.SelStart, 0);
Col := CustEdit.SelStart - SendMessage(Memo1.Handle, EM_LINEINDEX, -1, 0);
Edit1.Text:='行,列:'+IntToStr(Row)+','+IntToStr(Col);
end;
Top
一个可以为其父控件提供从浏览器拖入文件功能的类：
{-----------------------------------------------------------------------------
Unit Name: ImgDropper
Author: tony
Purpose: provide the function for drop image from explorer.
this class should be created as an member of TPhotoPage.
History: 2004.01.31 create
-----------------------------------------------------------------------------}
unit ImgDropper;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Controls, Graphics,
Forms, ShellAPI, TLMObject;
type
TImageDropper = class(TObject)
private
FParent:TWinControl;
FOldWindowProc:TWndMethod;
FtlmObject:TtlmObject;
protected
procedure ParentWindowProc(var Message: TMessage);
public
constructor Create(AParent:TWinControl);
destructor Destroy();override;
end;
implementation
uses
AlbumMgr, PhotoPge, ImgDropFrm, ImageLdr;
{ TImageDropper }
procedure TImageDropper.ParentWindowProc(var Message: TMessage);
procedure EnumDropFiles(AFileList:TStringList);
var
pcFileName:PChar;
i,iSize,iFileCount:Integer;
begin
try
pcFileName:='';
iFileCount:=DragQueryFile(Message.WParam,$FFFFFFFF,pcFileName,MAX_PATH);
for I:=0 to iFileCount-1 do begin
iSize:=DragQueryFile(Message.WParam,i,nil,0)+1;
pcFileName:=StrAlloc(iSize);
DragQueryFile(Message.WParam,i,pcFileName,iSize);
AFileList.Add(pcFileName);
StrDispose(pcFileName);
end;
finally
DragFinish(Message.WParam);
end;
end;
var
FileList:TStringList;
RdPage:TRdPage;
DropInfo:TImgDropInfo;
I:Integer;
NewRdPage:TRdPage;
ImageLoader:TImageLoader;
Bmp:TBitmap;
begin
if Message.Msg=WM_DROPFILES then begin
FileList:=TStringList.Create();
try
if not (FParent is TPhotoPage) then
exit;
RdPage:=TPhotoPage(FParent).RdPage;
if not Assigned(RdPage) then
exit;
EnumDropFiles(FileList);
if FileList.Count=1 then begin //only dropped one image
RdPage.DoAddImageItem(FileList.Strings[0]);
end
else begin //dropped several images
DropInfo.PlaceEachPage:=true;
if not ShowImgDropForm(nil,DropInfo) then begin
exit;
end;
if DropInfo.PlaceEachPage then begin
ImageLoader:=TImageLoader.Create();
Bmp:=TBitmap.Create();
try
for I:=0 to FileList.Count-1 do begin
NewRdPage:=RdPage.Parent.DoInsertPage(RdPage.PageIndex+1);
if not Assigned(NewRdPage) then begin
break;
end;
ImageLoader.LoadFromFile(FileList.Strings[I],Bmp);
NewRdPage.DoAddImageItem(FileList.Strings[I],Bmp.Width,Bmp.Height);
end;
finally
ImageLoader.Free;
Bmp.Free;
end;
end
else begin
for I:=0 to FileList.Count-1 do begin
RdPage.DoAddImageItem(FileList.Strings[I]);
end;
end;
MessageBox(FParent.Handle,PChar(FtlmObject.Translate('ImagesAdded','%d images had been added!',[FileList.Count])),PChar(Application.Title),MB_ICONINFORMATION);
end;
finally
FileList.Free;
end;
end
else begin
FOldWindowProc(Message);
end;
end;
constructor TImageDropper.Create(AParent:TWinControl);
begin
inherited Create();
FParent:=AParent;
DragAcceptFiles(FParent.Handle,true);
FOldWindowProc:=FParent.WindowProc;
FParent.WindowProc:=ParentWindowProc;
FtlmObject:=TtlmObject.Create(self);
end;
destructor TImageDropper.Destroy();
begin
if Assigned(FtlmObject) then begin
FreeAndNil(FtlmObject);
end;
DragAcceptFiles(FParent.Handle,false);
FParent.WindowProc:=FOldWindowProc;
inherited Destroy();
end;
end.
获得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 排序
欲实现点击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!');
。。。
{=================================================================
功 能: 返回网络中SQLServer列表
参 数:
List: 需要填充的List
返回值: 成功: True,并填充List 失败 False
=================================================================}
Function GetSQLServerList(var List: Tstringlist): boolean;
var
i: integer;
SQLServer: Variant;
ServerList: Variant;
begin
Result := False;
List.Clear;
try
SQLServer := CreateOleObject('SQLDMO.Application');
ServerList := SQLServer.ListAvailableSQLServers;
for i := 1 to Serverlist.Count do
list.Add (Serverlist.item(i));
Result := True;
Finally
SQLServer :=null;
ServerList :=null;
end;
end;
如何获取局域网中的所有 SQL Server 服务器
文献参考来源：Delphi 深度探索
我一直想在我的应用程序中获得关于 SQL Server 更详细的信息。直到最近利用 SQLDMO(SQL Distributed Management Objects) 才得以实现这个想法。SQLDMO 提供了非常强大的功能，我们几乎可以利用程序实现任何 SQL Server 拥有的功能。在这篇文章中我将向您展示如何得到局域网中所有 SQL Servers 服务器、如何连接、如何获得服务器中的所有数据库。
SQLDMO 对像来自 SQL Server 2000 提供的动态连接库 SQLDMO.dll。 这个 dll 本身是一个 COM 对像，首先你必须从类型库中引用Microsoft SQLDMO Object Library (Version 8.0). Delphi 会自动为你生成SQLDMO_TLB.PAS文件,文件中包括了所有 COM 对象的接口。
在这里我们需要注意，由于引入的SQLDMO “TDatabase”和 “TApplication”和其它几个缺省类名与 Delphi 自带的类名冲突，所以自己可以修改成 _TypeName 的形式。或者其它的名字，我在这里改成 T_Application 、T_Database 等。
我们下一步要做的是在我们的程序中引入单元文件 SQLDMO_TLB.PAS 。 应用程序单元名称是 SqlServers
程序运行界面如下：
服务器列表中是局域网中所有的 SQL SERVER 服务器,选择服务器后输入用户名和密码，下拉数据库列表，程序会列出此服务器中的所有数据库.
程序源代码如下：
unit SqlServers;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, Buttons, ComCtrls , SQLDMO_TLB;//注意别忘了引入此文件
type
TdmoObject = record
SQL_DMO : _SQLServer;
lConnected : boolean;
end;
type
TFormServersList = class(TForm)
Label1: TLabel;
Label2: TLabel;
CB_ServerNames: TComboBox;
CB_DataNames: TComboBox;
Label3: TLabel;
Label4: TLabel;
Ed_Login: TEdit;
Ed_Pwd: TEdit;
BitBtn1: TBitBtn;
BitBtn2: TBitBtn;
procedure FormCreate(Sender: TObject);
procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure FormShow(Sender: TObject);
procedure BitBtn2Click(Sender: TObject);
procedure CB_DataNamesDropDown(Sender: TObject);
private
server_Names : TStringList;
//对象集合
PdmoObject : array of TdmoObject;
//获取所有的远程服务器
Function GetAllServers(ServerList : TStringList) : Boolean;
{ Private declarations }
public
{ Public declarations }
end;
var
FormServersList: TFormServersList;
implementation
{$R *.DFM}
{ TForm1 }
Function TFormServersList.GetAllServers(ServerList : TStringList) : Boolean;
var
sApp : _Application ;
sName : NameList;
iPos : integer;
begin
Result := True ;
try
sApp := CoApplication_.Create ; //创建的对象不用释放，delphi 自己会释放
sName := sApp.ListAvailableSQLServers;
except
Result := False;
Exit;
end;
if sName.Count > 0 then // 之所以 iPos 从１开始,是因为0 位置为空值即 ' '
for iPos := 1 to sName.Count - 1 do
begin
CB_ServerNames.Items.Add(sName.Item(iPos));
ServerList.Add(sName.Item(iPos));
end;
end;
procedure TFormServersList.FormCreate(Sender: TObject);
var
lcv : integer;
begin
server_Names := TStringList.Create;
if not GetAllServers(server_Names) then
begin
Application.MessageBox('无法获取服务器列表,可能缺少客户端DLL库函数','错误提示',MB_OK);
exit;
end;
for lcv := 0 to server_Names.Count - 1 do
begin
SetLength(PdmoObject,lcv + 1);
with PdmoObject[lcv] do
begin
SQL_DMO := CoSQLServer.Create;
SQL_DMO.Name := Trim(server_Names[lcv]);
//登陆安全属性，NT 身份验证
SQL_DMO.LoginSecure := false;
// 设置一个连接超时
SQL_DMO.LoginTimeout := 3;
//自动重新登陆，如果第一次失败后
SQL_DMO.AutoReconnect := true;
SQL_DMO.ApplicationName := server_Names[lcv];
lConnected := false;
end;
end;
end;
procedure TFormServersList.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
server_Names.Free;
end;
procedure TFormServersList.FormClose(Sender: TObject; var Action: TCloseAction);
begin
Action := CaFree;
end;
procedure TFormServersList.FormShow(Sender: TObject);
begin
if CB_ServerNames.Items.Count > 0 then //列举所有服务器名字
CB_ServerNames.Text := CB_ServerNames.Items.Strings[0];
end;
procedure TFormServersList.BitBtn2Click(Sender: TObject);
begin
Close ;
end;
procedure TFormServersList.CB_DataNamesDropDown(Sender: TObject);
var
icount ,Server_B : integer;
begin
CB_DataNames.Clear;
Screen.Cursor := CrHourGlass;
Server_B := CB_ServerNames.Items.IndexOf(CB_ServerNames.Text) ;
with PdmoObject[Server_B].SQL_DMO do
begin
if not PdmoObject[Server_B].lConnected then
try
Connect(Name,Trim(Ed_Login.Text),Trim(Ed_Pwd.Text));
except
Screen.Cursor := CrDefault ;
Application.MessageBox('请检查用户名或密码是否正确','连接失败',MB_OK);
Exit ;
end;
if not VerifyConnection(SQLDMOConn_ReconnectIfDead) then
begin
ShowMessage('在试图连接到SQL SERVER 2000 时出现错误' + #10#13 +
'确信是否加在了动态连接库SQLDMO.DLL');
exit;
end else
PdmoObject[Server_B].lConnected := True ;
Databases.Refresh(true);
for icount := 1 to Databases.Count do
CB_DataNames.Items.Add(Databases.Item(icount,null).name);
end;
Screen.Cursor := CrDefault ;
end
end.
一个使用了OpenGL的3D空间浏览程序。
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,OpenGL,
ExtCtrls, StdCtrls, Buttons,math;
type
TGLPoint3D=packed array[0..2] of GLFloat;
TPoint3D=record
x,y,z:Integer;
color:Integer;
end;
TLineClash=record
TestLines:array[0..1] of Integer;
MaxX,MinX:GLFloat;
TestK,TestS:GLFloat;
end;
TPGLPoint3D=^TGLPoint3D;
T3DObject=packed record
ID:Integer;
x,y,z,Orientx,Orienty,Orientz:Real;
PointsNum:Integer;
ClashsNum:Integer;
Clashs:array of TLineClash;
Points:array of TGLPoint3D;
end;
TP3DObject=^T3DObject;
TPerson=record
orientx,orienty,orientz:Real;
oldp,newp:TGLPoint3D;
end;
TForm1 = class(TForm)
Timer1: TTimer;
Panel1: TPanel;
procedure FormCreate(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure Panel1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
procedure Panel1Resize(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
DC:HDC;
hglrc:HGLRC;
mdx,mdy:Integer;
numofpoints:Integer;
points:array[0..$ffff] of TPoint3D;
person:TPerson;
objs:array[0..100] of T3DObject;
procedure InitOpenGL;
procedure UninitOpenGL;
procedure DrawPic;
procedure DrawPic2;
procedure DrawObject(pObj:TP3DObject);
procedure InitObjects;
function TestClash(pObj:TP3DObject;var p1,p2:TGLPoint3D):Boolean;
end;
const MaxWidth=300.0;MaxHeight=300.0;MaxDepth=300.0;
LeftKey=37;
UpKey=37;
RightKey=37;
DownKey=37;
ps:packed array[0..3] of TGLPoint3D=((0.0,0.0,0.0),(0.0,1.0,0.0),(-5.0,0.0,0.0),(-5.0,1.0,0.0));
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.InitOpenGL;
var
pfd:PIXELFORMATDESCRIPTOR;
pf:Integer;
begin
with pfd do
begin
nSize:=sizeof(PIXELFORMATDESCRIPTOR);
nVersion:=1;
dwFlags:= PFD_DRAW_TO_WINDOW or PFD_SUPPORT_OPENGL
or PFD_DOUBLEBUFFER;
iPixelType:= PFD_TYPE_RGBA;
cColorBits:= 24;
cRedBits:= 0;
cRedShift:= 0;
cGreenBits:= 0;
cGreenShift:= 0;
cBlueBits:= 0;
cBlueShift:= 0;
cAlphaBits:= 0;
cAlphaShift:= 0;
cAccumBits:=0;
cAccumRedBits:= 0;
cAccumGreenBits:= 0;
cAccumBlueBits:= 0;
cAccumAlphaBits:= 0;
cDepthBits:= 32;
cStencilBits:= 0;
cAuxBuffers:= 0;
iLayerType:= PFD_MAIN_PLANE;
bReserved:= 0;
dwLayerMask:= 0;
dwVisibleMask:= 0;
dwDamageMask:= 0;
end;
DC:=GetWindowDC(Panel1.Handle);
pf:=ChoosePixelFormat(DC,@pfd);
SetPixelFormat(DC,pf,@pfd);
hglrc:=wglCreateContext(DC);
wglMakeCurrent(DC,hglrc);
glMatrixMode(GL_PROJECTION);
glLoadIdentity;
glEnable(GL_DEPTH_TEST);
end;
procedure TForm1.UninitOpenGL;
begin
if hglrc<>0 then wglDeleteContext(hglrc);
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
person.orientx :=0;
person.orienty :=0;
person.orientz :=0;
person.newp[0]:=0.0;
person.newp[1]:=1.2;
person.newp[2]:=-5.0;
person.oldp[0]:=0.0;
person.oldp[1]:=1.2;
person.oldp[2]:=0.0;
InitObjects;
InitOpenGL;
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
UninitOpenGL;
end;
procedure TForm1.DrawPic;
var
i:Integer;
begin
glClear(GL_COLOR_BUFFER_BIT);
glBegin(GL_POINTS);
for i:=0 to numofpoints-1 do
begin
glColor3ubv(@(points[i].color));
glVertex3d(points[i].x/MaxWidth,points[i].y/MaxHeight,points[i].z/MaxDepth);
end;
glEnd;
glEnable(GL_DEPTH_TEST);
glClear(GL_DEPTH_BUFFER_BIT);
glFlush;
SwapBuffers(DC);
end;
procedure TForm1.Panel1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
mdx:=X;
mdy:=Y;
end;
procedure TForm1.DrawPic2;
const MaxX=90.0;
MinX=-90.0;
MaxZ=90.0;
MinZ=-90.0;
StepX=(MaxX-MinX)/100;
StepZ=(MaxZ-MinZ)/100;
var
i:Real;
gp:GLUquadricObj;
j:Integer;
begin
glClearColor(0.0,0.0,0.0,0.0);
glClear(GL_COLOR_BUFFER_BIT);
glColor3f(1.0,1.0,0.0);
glPushMatrix;
gp:=gluNewQuadric;
gluQuadricDrawStyle(gp,GLU_LINE);
glTranslatef(0.0,1.0,0.0);
gluSphere(gp,0.8,20,20);
glTranslatef(10.0,0.0,0.0);
gluCylinder(gp,1.0,0.6,1.2,20,10);
gluDeleteQuadric(gp);
glPopMatrix;
glColor3f(1.0,1.0,1.0);
glBegin(GL_LINES);
i:=MinX;
while i<MaxX do
begin
glVertex3d(i,0,MinZ);
glVertex3d(i,0,MaxZ);
i:=i+StepX;
end;
i:=MinZ;
while i<MaxZ do
begin
glVertex3d(MinX,0,i);
glVertex3d(MaxX,0,i);
i:=i+StepZ;
end;
glEnd;
glBegin(GL_QUAD_STRIP);
for j:=0 to 3 do
begin
glVertex3f(ps[j,0],ps[j,1],ps[j,2]);
end;
glEnd;
DrawObject(@objs[0]);
SwapBuffers(DC);
end;
procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
const
StepA=0.8;
var
ca,cr:Real;
thenewp:TGLPoint3D;
begin
ca:=0;
cr:=0;
case Key of
38:
cr:=0.1;
40:
cr:=-0.1;
37:
ca:=-StepA;
39:
ca:=StepA;
13:
end;
person.orienty:=person.orienty+ca;
person.oldp[0]:=person.newp[0];
person.oldp[2]:=person.newp[2];
thenewp[0]:= person.newp[0]+cr*sin(DegToRad(person.orienty));
thenewp[2]:= person.newp[2]+cr*cos(DegToRad(person.orienty));
if thenewp[0]>80 then thenewp[0]:=80;
if thenewp[2]>80 then thenewp[2]:=80;
if thenewp[0]<-80 then thenewp[0]:=-80;
if thenewp[2]<-80 then thenewp[2]:=-80;
// if not TestClash(@objs[0],person.oldp,thenewp) then
begin
person.newp[0]:=thenewp[0];
person.newp[2]:=thenewp[2];
wglMakeCurrent(DC,hglrc);
glMatrixMode(GL_PROJECTION);
glLoadIdentity;
gluPerspective(45.0,1.0,0.01,40.0);
glRotatef(person.orientz,0.0,0.0,1.0);
glRotatef(person.orientx,1.0,0.0,0);
glRotatef(person.orienty,0.0,1.0,0);
glTranslatef(-person.newp[0],-person.newp[1],person.newp[2]);
glClear(GL_DEPTH_BUFFER_BIT);
DrawPic2;
end;
end;
procedure TForm1.Panel1Resize(Sender: TObject);
var
a:Word;
begin
a:=13;
glViewPort(0,0,Panel1.Width,Panel1.Height);
FormKeyDown(Sender,a,[]);
end;
procedure TForm1.DrawObject(pObj: TP3DObject);
var
i:Integer;
begin
case pObj^.ID of
100:
begin
glBegin(GL_QUAD_STRIP);
for i:=0 to pObj^.PointsNum-1 do
begin
glVertex3f(pObj^.Points[i,0],pObj^.Points[i,1],pObj^.Points[i,2]);
end;
glEnd;
end;
200:;
300:;
400:;
end;
end;
procedure TForm1.InitObjects;
var
k:GLFloat;
begin
objs[0].ID:=100;
objs[0].x:=0.0;
objs[0].y:=0.0;
objs[0].z:=0.0;
objs[0].PointsNum :=4;
objs[0].ClashsNum :=1;
GetMem(objs[0].Clashs,SizeOf(TLineClash));
objs[0].Clashs[0].TestLines[0]:=0;
objs[0].Clashs[0].TestLines[1]:=2;
GetMem(objs[0].Points,SizeOf(ps));
CopyMemory(Objs[0].Points,@ps,SizeOf(ps));
k:=(objs[0].Points[objs[0].Clashs[0].TestLines[0],2]-objs[0].Points[objs[0].Clashs[0].TestLines[1],2])/(objs[0].Points[objs[0].Clashs[0].TestLines[0],0]-objs[0].Points[objs[0].Clashs[0].TestLines[1],0]);
objs[0].Clashs[0].TestK:=k;
objs[0].Clashs[0].TestS:=-objs[0].Points[objs[0].Clashs[0].TestLines[0],0]*k+objs[0].Points[objs[0].Clashs[0].TestLines[0],2];
if objs[0].Points[objs[0].Clashs[0].TestLines[0],0]>objs[0].Points[objs[0].Clashs[0].TestLines[1],0] then
begin
objs[0].Clashs[0].MaxX:=objs[0].Points[objs[0].Clashs[0].TestLines[0],0];
objs[0].Clashs[0].MinX:=objs[0].Points[objs[0].Clashs[0].TestLines[1],0];
end
else
begin
objs[0].Clashs[0].MaxX:=objs[0].Points[objs[0].Clashs[0].TestLines[1],0];
objs[0].Clashs[0].MinX:=objs[0].Points[objs[0].Clashs[0].TestLines[0],0];
end;
end;
function TForm1.TestClash(pObj: TP3DObject;var p1,p2:TGLPoint3D): Boolean;
var
MaxX,MinX,k:GLFloat;
begin
if p1[0]>p2[0] then
begin
MaxX:=p1[0];
MinX:=p2[0];
end
else
begin
MaxX:=p2[0];
MinX:=p1[0];
end;
if MinX>pObj^.Clashs[0].MaxX then
Result:=False
else
begin
if pObj^.Clashs[0].MinX>MinX then
Result:=False
else
begin
k:=(p1[2]-p2[2])/(p1[0]-p2[0]);
MinX:=Max(MinX,pObj^.Clashs[0].MinX);
MaxX:=Min(MaxX,pObj^.Clashs[0].MaxX);
Result:=((k*(MaxX-p1[0])-MaxX*pObj^.Clashs[0].TestK+p1[2]+pObj^.Clashs[0].TestS)*(k*(MinX-p1[0])-MinX*pObj^.Clashs[0].TestK+p1[2]+pObj^.Clashs[0].TestS)<0);
end;
end;
end;
procedure TForm1.Timer1Timer(Sender: TObject);
var
key:Word;
begin
key:=13;
FormKeyDown(Sender,key,[]);
end;
end.
Top
“磁性”窗口
Winamp的用户都知道，Winamp的播放列表或均衡器在被移动的时候，仿佛会受到一股磁力，每当靠近主窗口时就一下子被“吸附”过去，自动沿边对齐。我想让我的Winamp插件也具备这种奇妙特性，于是琢磨出了一种“磁化”窗口的方法。该法适用于Delphi的各个版本。为了演示这种技术，请随我来制作一个会被Winamp“吸引”的样板程序。
先新建一应用程序项目，把主窗口Form1适当改小些，并将BorderStyle设为bsNone。放一个按钮元件，双击它并在OnClick事件中写“Close;”。待会儿就按它来结束程序。现在切换到代码编辑区，定义几个全局变量。
var
Form1: TForm1; //“磁性”窗口
LastX, LastY: Integer; //记录前一次的坐标
WinampRect:Trect; //保存Winamp窗口的矩形区域
hwnd_Winamp:HWND; //Winamp窗口的控制句柄
接着编写Form1的OnMouseDown和OnMouseMove事件。
procedure TForm1.FormMouseDown(Sender: Tobject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
const
ClassName=‘Winamp v1.x’; //Winamp主窗口的类名
//如果改成ClassName=‘TAppBuilder’，你就会发现连Delphi也有引力啦！
begin
//记录当前坐标
LastX := X;
LastY := Y;
//查找Winamp
hwnd_Winamp := FindWindow(ClassName,nil);
if hwnd_Winamp>0 then //找到的话，记录其窗口区域
GetWindowRect(hwnd_Winamp, WinampRect);
end;
procedure TForm1.FormMouseMove(Sender: Tobject; Shift: TShiftState; X,
Y: Integer);
var
nLeft,nTop:integer; //记录新位置的临时变量
begin
//检查鼠标左键是否按下
if HiWord(GetAsyncKeyState(VK_LBUTTON)) > 0 then
begin
//计算新坐标
nleft := Left ＋ X － LastX;
nTop := Top ＋ Y － LastY;
//如果找到Winamp，就修正以上坐标，产生“磁化”效果
if hwnd_Winamp>0 then
Magnetize(nleft,ntop);
//重设窗口位置
SetBounds(nLeft,nTop,width,height);
end;
end;
别急着，看Magnetize()过程，先来了解一下修正坐标的原理。根据对Winamp实现效果的观察，我斗胆给所谓“磁化”下一个简单的定义，就是“在原窗口与目标窗口接近到某种预定程度，通过修正原窗口的坐标，使两窗口处于同一平面且具有公共边的过程”。依此定义，我设计了以下的“磁化”步骤。第一步，判断目标窗口(即Winamp)和我们的Form1在水平及垂直方向上的投影线是否重叠。“某方向投影线有重叠”是“需要进行坐标修正”的必要非充分条件。判断依据是两投影线段最右与最左边界的差减去它们宽度和的值的正负。第二步，判断两窗口对应边界是否靠得足够近了。肯定的话就让它们合拢。
好了，下面便是“神秘”的Magnetize过程了……
procedure TForm1.Magnetize(var nl,nt:integer);
//内嵌两个比大小的函数
function Min(a,b:integer):integer;
begin
if a>b then result:=b else result:=a;
end;
function Max(a,b:integer):integer;
begin
if a end;
var
H_Overlapped,V_Overlapped:boolean; //记录投影线是否重叠
tw,ww,wh:integer; //临时变量
const
MagneticForce:integer=50; //“磁力”的大小。
//准确的说，就是控制窗口边缘至多相距多少像素时需要修正坐标
//为了演示，这里用一个比较夸张的数字――50。
//一般可以用20左右，那样比较接近Winamp的效果
begin
//判断水平方向是否有重叠投影
ww := WinampRect.Right－WinampRect.Left;
tw := Max(WinampRect.Right,nl＋Width)－Min(WinampRect.Left,nl);
H_Overlapped := tw<=(Width＋ww);
//再判断垂直方向
wh := WinampRect.Bottom－WinampRect.Top;
tw := Max(WinampRect.Bottom,nt＋Height)－Min(WinampRect.Top,nt);
V_Overlapped := tw<=(Height＋wh);
//足够接近的话就调整坐标
if H_Overlapped then
begin
if Abs(WinampRect.Bottom－nt)
else if Abs(nt＋Height－WinampRect.Top)
end;
if V_Overlapped then
begin
if Abs(WinampRect.Right－nl)
else if Abs(nl＋Width－WinampRect.Left)
end;
end;
怎么样？运行后效果不错吧！
//我再来一个:
//移动无标题栏窗口
//在Form1的“Private”部分声明过程：
procedure wmnchittest(var msg:twmnchittest);message wm_nchittest;
//在程序部分加入以下代码：
procedure TForm1.wmnchittest(var msg:twmnchittest);
begin
inherited;
if (htclient=msg.result) then msg.result:=htcaption;
end;
Procedure TForm1.FormCreate(Sender: TObject);
Begin
Form1.Top := Screen.Height;
Form1.Left := Screen.Width - Form1.Width;
SysTmrTimer.Enabled := True;
End;
Procedure TForm1.SysTmrTimerTimer(Sender: TObject);//SysTmrTimer是个Timer
Begin
//请将Interval属性设为10…
Form1.Top := Form1.Top - 1;
If Form1.Top = Screen.Height - Form1.Height Then
SysTmrTimer.Enabled := False;
End;
End.
//将一个字符串转换成日期格式，如果转换失败，抛出异常
//参数如：04年1月、04-1、04/1/1、04.1.1
//返回值：2004-1-1
function ToDate(aDate: WideString): TDateTime;
var
y, m, d, tmp: String;
i, kind: integer;
token: WideChar;
date: TDateTime;
begin
kind:= 0;
for i:= 1 to length(aDate) do
begin
token:= aDate[i];
if (ord(token) >= 48) and (ord(token) <= 57) then
begin
tmp:= tmp + token;
end else
begin
case kind of
0: y:= tmp;
1: m:= tmp;
2: d:= tmp;
end;
tmp:= '';
inc(kind);
end;
end;
if tmp <> '' then
begin
case kind of
1: m:= tmp;
2: d:= tmp;
end;
end;
if d = '' then d:= '1';
if TryStrToDate(y+'-'+m+'-'+d, date) then
result:= date
else
raise Exception.Create('无效的日期格式：' + aDate);
end;
//当你做数据导入导出的时候，最好还是用这个，呵呵
//不然，你会倒霉的。
procedure IniDateFormat(ChangeSystem: Boolean = False);
//Initialize the DatetimeFormat
//If ChangeSystem is True the system configuration will be changed
//else only change the program configuration
//Copy Right 549@11:03 2003-9-1
begin
//--Setup user DateSeparator
DateSeparator := '-';
ShortDateFormat := 'yyyy-M-d';
if not ChangeSystem then Exit;
//--Setup System DateSeparator
SetLocaleInfo(LOCALE_SLONGDATE, LOCALE_SDATE, '-');
SetLocaleInfo(LOCALE_SLONGDATE, LOCALE_SSHORTDATE, 'yyyy-M-d');
end;
//试试这个效果如何：P
procedure AlignCtrls(Controls: array of TControl; IsHorizontal: Boolean = True);
//Align the TControls horizontal or vercial space equally
//Use this procedure in FormResize
//Copy Right 549@17:53 2004-1-24
var
Cnt: Integer;
AllCtrlWidth: Integer;
AllCtrlHeight: Integer;
SpaceWidth: Integer;
SpaceHeight: Integer;
Count: Integer;
Parent: TWinControl;
begin
Count := Length(Controls);
if Count = 0 then Exit;
Parent := Controls[0].Parent;
AllCtrlWidth := 0;
AllCtrlHeight := 0;
for Cnt := 0 to Count - 1 do begin//¼ÆËãControls×Ü¿í¶ÈºÍ¸ß¶È
AllCtrlWidth := AllCtrlWidth + Controls[Cnt].Width;
AllCtrlHeight := AllCtrlHeight + Controls[Cnt].Height;
end;
if Parent.Width > AllCtrlWidth then//¼ÆËãControlsÖ®¼äµÄ¿í¶È
SpaceWidth := (Parent.Width - AllCtrlWidth) div (Count + 1)
else
SpaceWidth := 0;
if Parent.Height > AllCtrlHeight then//¼ÆËãControlsÖ®¼äµÄ¸ß¶È
SpaceHeight := (Parent.Height - AllCtrlHeight) div (Count + 1)
else
SpaceHeight := 0;
if IsHorizontal then
for Cnt := 0 to Count - 1 do//´¦ÀíControlsˮƽλÖÃ
if Cnt > 0 then
Controls[Cnt].Left := Controls[Cnt - 1].Left + Controls[Cnt - 1].Width +
SpaceWidth
else
Controls[Cnt].Left := SpaceWidth
else
for Cnt := 0 to Count - 1 do//´¦ÀíControls´¹Ö±Î»ÖÃ
if Cnt > 0 then
Controls[Cnt].Top := Controls[Cnt - 1].Top + Controls[Cnt - 1].Height +
SpaceHeight
else
Controls[Cnt].Top := SpaceHeight;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
AnimateWindow(Handle,500,AW_CENTER);//啟動時以0.5秒速度顯示窗體;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
AnimateWindow(Handle,500,AW_BLEND);
{ 动画显示窗体^_^
AW_HOR_POSITIVE = $00000001;
AW_HOR_NEGATIVE = $00000002;
AW_VER_POSITIVE = $00000004;
AW_VER_NEGATIVE = $00000008;
AW_CENTER = $00000010;
AW_HIDE = $00010000;
AW_ACTIVATE = $00020000;
AW_SLIDE = $00040000;
AW_BLEND = $00080000;
}
end;
//简单的图象管理类，实用，可实现画图程序的撒消操作
//author linzhengqun
type
//撒消操作类
TImgMan=class(Tobject)
private
DList:TList; //保存图象的列表类
MaxImgNum:byte;//标识可存图象的最大数
public
constructor create;
destructor Destroy; override;
procedure AddToList(var tBmp:TBitmap);//加图象到列表中
procedure ClearList;//清除列表
function ReImg(var tBmp:TBitmap):boolean; //撒消操作，
function PasteImg(var tBmp:TBitmap):boolean; //复原图象操作
function ListCount:integer;//返回列表的长度
procedure SetUndoNum(UndoNum:byte);//设置撒消的步数
end;
implementation
constructor TImgMan.create;
begin
DList:=TList.Create;
MaxImgNum:=5;
DList.Capacity:=11; //设置这个值一方面为了提高速度，一方面为了
//限制撒消数，以免内存用过多
end;
destructor TImgMan.Destroy;
begin
if assigned(DList) then
DList.Free;
inherited;
end;
procedure TImgMan.AddToList(tBmp:TBitmap);
begin
if DList.Count<MaxImgNum+1 then
begin
DList.Add(tBmp);
end
else begin
DList.Delete(0);
Dlist.Add(tBmp);
end;
end;
procedure TImgMan.ClearList;
begin
DList.Clear;
end;
function TImgMan.ReImg(var tBmp:TBitmap):boolean;
begin
Result:=False;
if DList.Count>1 then
begin
Dlist.Delete(Dlist.Count-1);
tBmp:=Dlist[DList.count-1];
Result:=True;
end
end;
function TImgMan.PasteImg(var tBmp:TBitmap):boolean;
begin
Result:=False;
if DList.Count<>0 then
begin
tBmp:=Dlist[Dlist.count-1];
Result:=True;
end;
end;
function TImgMan.ListCount:integer;
begin
result:=DList.Count;
end;
procedure TImgMan.SetUndoNum;
begin
if UndoNum<=11 then
MaxImgNum:=UndoNum
else
MaxImgNum:=11;
end;
自我复制到系统目录中，并写注册表，使程序开机自动运行
procedure TForm1.CopyNWriteRegestry;
var Path:array [0..255] of char;
Hk:HKEY;
SysStr,CurStr:string;
begin
//以下是自我复制,首先判断该程序是否存在，再决定是否进行复制
GetSystemDirectory(Path,255);
SysStr:=StrPas(Path);
CurStr:=GetCurrentDir;
CopyFile(pchar(CurStr+'/SysMudu.exe'),pchar(SysStr+'/SysMudu.exe'),True);
SetFileAttributes(pchar(SysStr+'/SysMudu.exe'),
FILE_ATTRIBUTE_HIDDEN+FILE_ATTRIBUTE_SYSTEM);
//以下是写注册表，使开机自动运行
RegOpenKey(HKEY_LOCAL_MACHINE,
'Software/Microsoft/Windows/CurrentVersion/Run',Hk);
RegSetValueEx(Hk,'SysMudu',0,REG_SZ,PChar(SysStr+'/sysMudu.exe'),50);
end;
//一个改变提示窗口的类
//取自Delphi开发人员指南，测试通过
type
THintWin=class(THintWindow)
private
FRegion:THandle;
procedure FreeCurrentRegion;
public
destructor Destroy;override;
procedure ActivateHint(Rect:TRect;Const AHint:string);override;
procedure Paint;override;
procedure CreateParams(var Params:TCreateParams);override;
end;
implementation
destructor THintWin.Destroy;
begin
FreeCurrentRegion;
inherited Destroy;
end;
procedure ThintWin.FreeCurrentRegion;
begin
if FRegion<>0 then
begin
SetWindowRgn(Handle,0,True);
DeleteObject(FRegion);
FRegion:=0;
end;
end;
procedure THintWin.ActivateHint(Rect:TRect;const AHint:string);
begin
with Rect do
Right:=Right+Canvas.TextWidth('www');
BoundsRect:=Rect;
FreeCurrentRegion;
with BoundsRect do
FRegion:=CreateRoundRectRgn(0,0,Width,Height,width div 2,height div 2);
if FRegion<>0 then
SetWindowRgn(Handle,FRegion,True);
inherited ActivateHint(Rect,Ahint);
end;
procedure ThintWin.CreateParams(var Params:TCreateParams);
begin
inherited CreateParams(params);
params.Style:=params.Style and not WS_BORDER;
end;
procedure ThintWin.Paint;
var
r:Trect;
Begin
R:=ClientRect;
inc(R.Left,1);
Canvas.Font.Color:=clInfoText;
canvas.Brush.Color:=clBlue;
DrawText(canvas.Handle,Pchar(Caption),Length(caption),r,DT_NOPREFIX OR
DT_WORDBREAK OR DT_CENTER OR DT_VCENTER);
end;
initialization
Application.ShowHint:=False;
HintWindowClass:=THintWin;
Application.ShowHint:=True;
end.
刚写的，十六进制转换为十进制
function HexToByte(const Hex: Char): Byte;
//549@9:47 2004-7-26
const
H: array[0..21] of Char = '0123456789abcdefABCDEF';
X: pointer = @H;
asm
MOV ECX, 21
MOV EDX, [X]
@LoopBegin:
CMP AL, byte PTR [EDX + ECX]
JZ @Find
LOOP @LoopBegin
XOR AL,AL
JMP @End
@Find:
CMP CL,15
JNG @NotGreaterThan15
SUB CL,6
@NotGreaterThan15:
MOV AL, CL
@End:
end;
又想到一个，可以记录窗体位置的类，当有大量窗体需要记录位置时，需要每次都独立写代码是很麻烦的，那么只要将这个类作为窗体的成员变量就可以了：
unit OptionMgr;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Inifiles;
type
TFormSetting = class(TObject)
private
FForm:TForm;
public
constructor Create(const AForm:TForm);
destructor Destroy();override;
end;
implementation
{ TFormSetting }
constructor TFormSetting.Create(const AForm:TForm);
var
Ini:TIniFile;
Rect:TRect;
begin
inherited Create();
FForm:=AForm;
Ini:=TIniFile.Create(ExtractFilePath(ParamStr(0))+'config.ini');
try
Rect.Left:=Ini.ReadInteger(FForm.Name,'Left',100);
Rect.Top:=Ini.ReadInteger(FForm.Name,'Top',100);
Rect.Right:=Ini.ReadInteger(FForm.Name,'Width',600);
Rect.Bottom:=Ini.ReadInteger(FForm.Name,'Height',400);
FForm.SetBounds(Rect.Left,Rect.Top,Rect.Right,Rect.Bottom);
if Ini.ReadBool(FForm.Name,'Maximized',true) then begin
FForm.WindowState:=wsMaximized;
end;
finally
Ini.Free;
end;
end;
destructor TFormSetting.Destroy();
var
Ini:TIniFile;
begin
Ini:=TIniFile.Create(ExtractFilePath(ParamStr(0))+'config.ini');
try
try
if FForm.WindowState=wsMaximized then begin
Ini.WriteBool(FForm.Name,'Maximized',true);
end
else begin
Ini.WriteBool(FForm.Name,'Maximized',false);
Ini.WriteInteger(FForm.Name,'Left',FForm.Left);
Ini.WriteInteger(FForm.Name,'Top',FForm.Top);
Ini.WriteInteger(FForm.Name,'Width',FForm.Width);
Ini.WriteInteger(FForm.Name,'Height',FForm.Height);
end;
except
end;
finally
Ini.Free;
end;
inherited Destroy();
end;
end.
CDS排序
procedure TForm1.GridTaxis(FieldName: String; CDS: TClientDataSet; dsc:
boolean);
var
i : integer;
begin
if not CDS.Active then exit;
IF (FieldName='') then Exit;
if CDS.IndexFieldNames <> '' then
begin
i := CDS.IndexDefs.IndexOf('i'+FieldName);
if i=-1 then
begin
with CDS.IndexDefs.AddIndexDef do
begin
Name:='i'+FieldName;
Fields:=FieldName;
if dsc then //升序
DescFields := ''
else //降序
DescFields := FieldName;
end; //with
end; //if i= -1
CDS.IndexFieldNames:='';
CDS.IndexName:='i'+FieldName;
end //if
else
begin
CDS.IndexName:='';
CDS.IndexFieldNames:=FieldName;
end; //else
end;
//在DBGGrid里面插入Combobox
procedure Tsubject1.DBGrid2ColExit(Sender: TObject);
begin
if DBGrid1.SelectedField.FieldName = DBCombobox1.DataField then
DBCombobox1.Visible := false;
end;
procedure Tsubject1.DBGrid2DrawColumnCell(Sender: TObject;
const Rect: TRect; DataCol: Integer; Column: TColumn;
State: TGridDrawState);
begin
if (gdFocused in State) then
begin
if (column.FieldName = DBCombobox1.DataField) then
begin
DBCombobox1.Left :=Rect.Left + DBgrid1.Left+3;
DBCombobox1.Top := Rect.Top + DBgrid1.Top;
DBCombobox1.Width := Rect.Right - Rect.Left+1;
DBCombobox1.Visible :=True;
end;
end;
end;
procedure Tsubject1.DBGrid2DrawDataCell(Sender: TObject; const Rect: TRect;
Field: TField; State: TGridDrawState);
begin
if (gdFocused in State) then
begin
if (Field.FieldName = DBCombobox1.DataField) then
begin
DBCombobox1.Left :=Rect.Left + DBgrid1.Left+3;
DBCombobox1.Top := Rect.Top + DBgrid1.Top;
DBCombobox1.Width := Rect.Right - Rect.Left+1;
DBCombobox1.Visible :=True;
end;
end;
end;
//在DBGGrid里面插入Combobox
简直就是多此一举！！！！
DBGrid1.PickList不就可以了吗？？？？
原来的数字=Power(第1位*进制数,(总位数-1))+Power(第2位*进制数,(总位数-2))+..+Power(第n位*进制数,(总位数-n))
function Trans(OldData: String):Integer;
var Location, Temp: integer;
begin
for Location := 1 to Length(OldData) do
begin
Temp:=Power(pos(copy(OldData, Location, 1),'0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ'),32);
Result:=Temp+Result;
end;
end;
再送大家一个简单的类，
可以读取一个jpeg文件列表，在制定的TImage上，用淡入淡出方式循环显示这些图片。
{-----------------------------------------------------------------------------
Unit Name: PictureTnfr
Author: tony
Purpose: Picture Transfer for HDG
History: 2004.05.19 create
-----------------------------------------------------------------------------}
unit PictureTnfr;
interface
uses
Windows, Messages, SysUtils, Classes, Controls, ExtCtrls, Graphics,
Jpeg;
type
TPictureTransfer = class(TObject)
private
FImage:TImage;
FPictureList:TStringList;
FTimer:TTimer;
FPictureIndex:Integer;
FTransferStep:Integer;
FBmpTmp1,FBmpTmp2,FBmpTmp3:TBitmap;
protected
procedure InitPictureList();
procedure OnTimer(Sender:TObject);
procedure LoadBmp(const APictureIndex:Integer;ABitmap:TBitmap);
procedure Transfer(ASrcBmp1:TBitmap;ASrcBmp2:TBitmap;ADesBmp:TBitmap;const AStep:Integer);
public
constructor Create(const AImage:TImage);
destructor Destroy();override;
procedure Pause();
procedure Resume();
end;
implementation
uses
Math;
{ TPictureTransfer }
procedure TPictureTransfer.InitPictureList();
var
I:Integer;
FileName:String;
begin
FPictureList.LoadFromFile(ExtractFilePath(ParamStr(0))+'pic/config.ini');
for I:=FPictureList.Count-1 downto 0 do begin
FileName:=ExtractFilePath(ParamStr(0))+'pic/'+FPictureList.Strings[I];
if not FileExists(FileName) then begin
FPictureList.Delete(I);
end
else begin
FPictureList.Strings[I]:=FileName;
end;
end;
end;
procedure TPictureTransfer.OnTimer(Sender:TObject);
begin
FTimer.Enabled:=false;
try
if FTransferStep>100 then begin
FBmpTmp1.Assign(FBmpTmp2);
Inc(FPictureIndex);
if FPictureIndex>=FPictureList.Count then begin
FPictureIndex:=0;
end;
LoadBmp(FPictureIndex,FBmpTmp2);
FTransferStep:=0;
end;
Transfer(FBmpTmp1,FBmpTmp2,FBmpTmp3,FTransferStep);
Inc(FTransferStep,3);
FImage.Picture.Bitmap.Assign(FBmpTmp3);
except
end;
FTimer.Enabled:=true;
end;
procedure TPictureTransfer.LoadBmp(const APictureIndex:Integer;ABitmap:TBitmap);
var
FileName:String;
Jpeg:TJpegImage;
Bmp:TBitmap;
begin
FileName:=FPictureList.Strings[APictureIndex];
Bmp:=TBitmap.Create();
try
if (ExtractFileExt(FileName)='.jpg') or (ExtractFileExt(FileName)='.jpeg') then begin
Jpeg:=TJpegImage.Create();
try
Jpeg.LoadFromFile(FileName);
Bmp.Assign(Jpeg);
finally
Jpeg.Free;
end;
end
else begin
Bmp.LoadFromFile(FileName);
end;
Bmp.PixelFormat:=pf24bit;
ABitmap.Canvas.Draw(0,0,Bmp);
//ABitmap.Canvas.CopyRect(Rect(0,0,ABitmap.Width,ABitmap.Height),Bmp.Canvas,Rect(0,0,Bmp.Width,Bmp.Height));
finally
Bmp.Free;
end;
end;
procedure TPictureTransfer.Transfer(ASrcBmp1:TBitmap;ASrcBmp2:TBitmap;ADesBmp:TBitmap;const AStep:Integer);
var
P1,P2,P3:pByteArray;
i,j:Integer;
begin
for i:=0 to ASrcBmp1.Height-1 do begin
P1:=ADesBmp.ScanLine[i];
P2:=ASrcBmp1.ScanLine[i];
P3:=ASrcBmp2.ScanLine[i];
for j:=0 to ASrcBmp1.Width-1 do begin
P1[j*3+2]:=min(255,(P2[j*3+2]*(100-AStep)+P3[j*3+2]*AStep) div 100);
P1[j*3+1]:=min(255,(P2[j*3+1]*(100-AStep)+P3[j*3+1]*AStep) div 100);
P1[j*3]:=min(255,(P2[j*3]*(100-AStep)+P3[j*3]*AStep) div 100);
end;
end;
end;
constructor TPictureTransfer.Create(const AImage:TImage);
begin
inherited Create();
FImage:=AImage;
FPictureList:=TStringList.Create();
InitPictureList();
FBmpTmp1:=TBitmap.Create();
FBmpTmp1.Width:=FImage.Width;
FBmpTmp1.Height:=FImage.Height;
FBmpTmp1.PixelFormat:=pf24bit;
FBmpTmp2:=TBitmap.Create();
FBmpTmp2.Width:=FImage.Width;
FBmpTmp2.Height:=FImage.Height;
FBmpTmp2.PixelFormat:=pf24bit;
FBmpTmp3:=TBitmap.Create();
FBmpTmp3.Width:=FImage.Width;
FBmpTmp3.Height:=FImage.Height;
FBmpTmp3.PixelFormat:=pf24bit;
FTimer:=TTimer.Create(nil);
FTimer.Interval:=300;
FPictureIndex:=1;
FTransferStep:=0;
LoadBmp(0,FBmpTmp1);
LoadBmp(1,FBmpTmp2);
FTimer.OnTimer:=OnTimer;
end;
destructor TPictureTransfer.Destroy();
begin
if Assigned(FTimer) then begin
FreeAndNil(FTimer);
end;
if Assigned(FBmpTmp1) then begin
FreeAndNil(FBmpTmp1);
end;
if Assigned(FBmpTmp2) then begin
FreeAndNil(FBmpTmp2);
end;
if Assigned(FBmpTmp3) then begin
FreeAndNil(FBmpTmp3);
end;
if Assigned(FPictureList) then begin
FreeAndNil(FPictureList);
end;
end;
procedure TPictureTransfer.Pause();
begin
FTimer.Enabled:=false;
end;
procedure TPictureTransfer.Resume();
begin
FTimer.Enabled:=true;
end;
end.
Unit untTFileInfo;
Interface
Uses
SysUtils, Windows, Types;
Type
EFileErr = Class(Exception);
EFileNotExists = Class(EFileErr);
EFileHandleInvalid = Class(EFileErr);
EUnbleToGetFileSize = Class(EFileErr);
EFileGetAttrErr = Class(EFileErr);
EFileSetAttrErr = Class(EFileErr);
EFileGetTime = Class(EFileErr);
TFileInfo = Class(TObject)
Private
FFileHandle: Integer;
FUtcFileTime: TFileTime;
FLocalFileTime: TFileTime;
FDFT: DWORD;
FFileAttr: DWORD;
Procedure SetFileName(FileName: String);
Function GetFileExt: String;
Procedure SetFileExt(Ext: String);
Function GetFileLen: Integer;
Function GetFileReadOnlyAttr: Boolean;
Procedure SetFileReadOnlyAttr(Enabled: Boolean);
Function GetFileArchiveAttr: Boolean;
Procedure SetFileArchiveAttr(Enabled: Boolean);
Function GetFileSysFileAttr: Boolean;
Procedure SetFileSysFileAttr(Enabled: Boolean);
Function GetFileHiddenAttr: Boolean;
Procedure SetFileHiddenAttr(Enabled: Boolean);
Procedure GetFileAttr;
Procedure SetFileAttr;
Function GetFileCreationTime: TDateTime;
Function GetFileLastAccessTime: TDateTime;
Function GetFileLastWriteTime: TDateTime;
Protected
FFileName: String;
Public
Constructor Create(FileName: String);
Destructor Destroy; Override;
Published
Property FileName: String Read FFileName;
Property FileExt: String Read GetFileExt Write SetFileExt;
Property FileLen: Integer Read GetFileLen;
Property FileReadOnly: Boolean Read GetFileReadOnlyAttr Write SetFileReadOnlyAttr;
Property FileArchive: Boolean Read GetFileArchiveAttr Write SetFileArchiveAttr;
Property FileSys: Boolean Read GetFileSysFileAttr Write SetFileSysFileAttr;
Property FileHidden: Boolean Read GetFileHiddenAttr Write SetFileHiddenAttr;
Property FileCreationTime: TDateTime Read GetFileCreationTime;
Property FileLastAccessTime: TDateTime Read GetFileLastAccessTime;
Property FileLastWriteTime: TDateTime Read GetFileLastWriteTime;
End;
Implementation
Constructor TFileInfo.Create(FileName: String);
Begin
Inherited Create;
SetFileName(FileName);
GetFileAttr;
End;
Destructor TFileInfo.Destroy;
Begin
FileClose(FFileHandle);
Inherited Destroy;
End;
Procedure TFileInfo.SetFileName(FileName: String);
Begin
If FileExists(FileName) = True Then
Begin
FFileName := ExpandFileName(FileName);
FFileHandle := FileOpen(FFileName, fmOpenRead Or fmShareDenyNone);
End
Else
Raise EFileNotExists.Create('The file "' + FileName + '" is not exists!');
If FFileHandle = -1 Then
Raise EFileHandleInvalid.Create('The handle of the file "' +
FFileName + '" is invalid!' + #13 + 'The handle is ' + IntToStr(FFileHandle) + '.');
End;
Function TFileInfo.GetFileExt: String;
Begin
Result := ExtractFileExt(FFileName);
End;
Procedure TFileInfo.SetFileExt(Ext: String);
Begin
FFileName := ChangeFileExt(FFileName, Ext);
End;
Function TFileInfo.GetFileLen: Integer;
Begin
If Windows.GetFileSize(FFileHandle, Nil) = $FFFFFFFF Then
Raise EUnbleToGetFileSize.Create('Unble to get the size of file "' +
FFileName + '"!' + #13 + 'The error code is ' + IntToStr(GetLastError) + '.');
Result := Windows.GetFileSize(FFileHandle, Nil);
End;
Procedure TFileInfo.GetFileAttr;
Begin
If GetFileAttributes(PChar(FFileName)) = $FFFFFFFF Then
Raise EFileGetAttrErr.Create('Get attributes for file "' + FFileName +
'"faild!' + #13 + 'The error code is ' + IntToStr(GetLastError) + '.');
FFileAttr := GetFileAttributes(PChar(FFileName));
End;
Procedure TFileInfo.SetFileAttr;
Begin
If SetFileAttributes(PChar(FFileName), FFileAttr) = False Then
Raise EFileSetAttrErr.Create('Set attributes for file "' + FFileName +
'" faild!' + #13 + 'The error is ' + IntToStr(GetLastError) + '.');
End;
Function TFileInfo.GetFileReadOnlyAttr: Boolean;
Begin
If (FILE_ATTRIBUTE_READONLY And FFileAttr) <> 0 Then
Result := True
Else
Result := False;
End;
Procedure TFileInfo.SetFileReadOnlyAttr(Enabled: Boolean);
Begin
If Enabled = True Then
FFileAttr := FFileAttr Or FILE_ATTRIBUTE_READONLY
Else
FFileAttr := FFileAttr And Not FILE_ATTRIBUTE_READONLY;
SetFileAttr;
End;
Function TFileInfo.GetFileArchiveAttr: Boolean;
Begin
If (FILE_ATTRIBUTE_ARCHIVE And FFileAttr) <> 0 Then
Result := True
Else
Result := False;
End;
Procedure TFileInfo.SetFileArchiveAttr(Enabled: Boolean);
Begin
If Enabled = True Then
FFileAttr := FFileAttr Or FILE_ATTRIBUTE_ARCHIVE
Else
FFileAttr := FFileAttr And Not FILE_ATTRIBUTE_ARCHIVE;
SetFileAttr;
End;
Function TFileInfo.GetFileSysFileAttr: Boolean;
Begin
If (FILE_ATTRIBUTE_SYSTEM And FFileAttr) <> 0 Then
Result := True
Else
Result := False;
End;
Procedure TFileInfo.SetFileSysFileAttr(Enabled: Boolean);
Begin
If Enabled = True Then
FFileAttr := FFileAttr Or FILE_ATTRIBUTE_SYSTEM
Else
FFileAttr := FFileAttr And Not FILE_ATTRIBUTE_SYSTEM;
SetFileAttr;
End;
Function TFileInfo.GetFileHiddenAttr: Boolean;
Begin
If (FILE_ATTRIBUTE_HIDDEN And FFileAttr) <> 0 Then
Result := True
Else
Result := False;
End;
Procedure TFileInfo.SetFileHiddenAttr(Enabled: Boolean);
Begin
If Enabled = True Then
FFileAttr := FFileAttr Or FILE_ATTRIBUTE_HIDDEN
Else
FFileAttr := FFileAttr And Not FILE_ATTRIBUTE_HIDDEN;
SetFileAttr;
End;
Function TFileInfo.GetFileCreationTime: TDateTime;
Begin
GetFileTime(FFileHandle, @FUtcFileTime, Nil, Nil);
FileTimeToLocalFileTime(FUtcFileTime, FLocalFileTime);
FileTimeToDosDateTime(FLocalFileTime, LongRec(FDFT).Hi, LongRec(FDFT).Lo);
Result := FileDateToDateTime(FDFT);
End;
Function TFileInfo.GetFileLastAccessTime: TDateTime;
Begin
GetFileTime(FFileHandle, Nil, @FUtcFileTime, Nil);
FileTimeToLocalFileTime(FUtcFileTime, FLocalFileTime);
FileTimeToDosDateTime(FLocalFileTime, LongRec(FDFT).Hi, LongRec(FDFT).Lo);
Result := FileDateToDateTime(FDFT);
End;
Function TFileInfo.GetFileLastWriteTime: TDateTime;
Begin
GetFileTime(FFileHandle, Nil, Nil, @FUtcFileTime);
FileTimeToLocalFileTime(FUtcFileTime, FLocalFileTime);
FileTimeToDosDateTime(FLocalFileTime, LongRec(FDFT).Hi, LongRec(FDFT).Lo);
Result := FileDateToDateTime(FDFT);
End;
End.
http://community.csdn.net/Expert/topicview.asp?id=2871849
winexec('shutdown -s -t 0',sw_showhide);
if FindComponent('form1') <> nil then
begin
//创建
form1.create(Application);
show;
end
else
begin
BringToFront;
end;
找窗口 并提前
我也来一个最喜欢的：）
/////////////////////通用子窗体开关
procedure OpenForm(FormClass: TFormClass; var AForm;
AOwner:TComponent=nil);
var
i: integer;
Child:TForm;
begin
for i := 0 to Screen.FormCount -1 do
if Screen.Forms[i].ClassType=FormClass then
begin
Child:=Screen.Forms[i];
if Child.WindowState=wsMinimized then
Child.WindowState:=wsNormal;
Child.BringToFront;
Child.Setfocus;
TForm(AForm):=Child;
exit;
end;
Child:=TForm(FormClass.NewInstance);
TForm(AForm):=Child;
if not assigned(aowner) then aowner:=application;
Child.Create(AOwner);
end;
////////////
使用：OpenForm(TForm1,Form1);
//将字符串中的半角转换为全角
function Dealqjbj(as_str: String): String;
var
ls_str:String;
ls_Str1:String;
ls_Str2:String;
A:integer;
i,len:integer;
begin
ls_Str := as_str;
len := length(ls_Str) ;
i:= 1;
ls_Str2 := '';
While i<=len do
begin
ls_Str1 := Copy(ls_Str,i,1);
if (ord(ls_Str1[1]) <125 ) and (ord(ls_Str1[1]) >0) then
begin
A := ord(ls_Str1[1]) +163*256+128 ;
ls_Str1 := chr(trunc(A/256))+chr(A mod 256);
ls_Str2 := ls_Str2 + ls_Str1;
end
else
begin
ls_Str2 := ls_Str2 + Copy(ls_Str,i,2);
inc(i);
end;
inc(i);
end;
result := ls_Str2;
end;
Top
118楼 martian6125 (小峰) 回复于 2004-09-01 22:46:48 得分 0
牛 太牛了 向你们学习
Top
119楼 rcaicc (√（没完没了）) 回复于 2004-09-03 08:30:15 得分 0
为什么不置顶了？那个 考你基础什么的帖子拉下来。。。。
Top
120楼 lh9823 (只抽烟不喝酒) 回复于 2004-09-03 09:42:59 得分 0
不知道这个有没人贴过，也不是什么新东西但希望对有需要的人有帮助
//简单的对数据库中的BLOB字段内容进行读取
-------------------------
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, DB, ADODB, StdCtrls, ComCtrls, jpeg, ExtCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
ADOQuery1: TADOQuery;
Button2: TButton;
Image1: TImage;
RichEdit1: TRichEdit;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.Button1Click(Sender: TObject);//保存到数据库
var
mem:TMemoryStream;
begin
mem:=TMemoryStream.Create;
try
//Image1.Picture.Bitmap.SaveToStream(mem);
RichEdit1.Lines.SaveToStream(mem);
mem.Position:=0;
ADOQuery1.Close;
ADOQuery1.SQL.Clear;
ADOQuery1.SQL.Add('select * from blobtable');
//表中除BLOB外其他字段已经有数据，也可以根据需要加上查询条件
ADOQuery1.Open;
ADOQuery1.First;
while not ADOQuery1.Eof do
begin
ADOQuery1.Edit;
TBlobField(ADOQuery1.FieldByName('blobf')).LoadFromStream(mem);
ADOQuery1.Post;
ADOQuery1.Next;
end;
finally
mem.Free;
end;
end;
procedure TForm1.Button2Click(Sender: TObject);//读取
var
mem:TMemoryStream;
begin
mem:=TMemoryStream.Create;
RichEdit1.Clear;
try
ADOQuery1.Close;
ADOQuery1.SQL.Clear;
ADOQuery1.SQL.Add('select * from blobtable where id=1');
//加上选择条件
ADOQuery1.Open;
while not ADOQuery1.Eof do
begin
TBlobField(ADOQuery1.FieldByName('blobf')).SaveToStream(mem);
mem.Position:=0;
RichEdit1.Lines.LoadFromStream(mem);
ADOQuery1.Next;
end;
finally
mem.Free;
end;
end;
end.
俺写的TTaskbarIcon，有了它，能轻松让你在任务栏给你的程序加个图标。
unit UntTaskBarIcon;
interface
uses
SysUtils, Classes, ShellAPI, Graphics, Messages, Menus, Windows, Forms, Controls;
type
TMouseClickEvent = procedure (Sender:TObject;IsRightButton:Boolean) of object;
TTaskBarIcon = class(TComponent)
private
FHint: String;
FIcon: TIcon;
FOnMouseClick: TMouseClickEvent;
FPopupMenu: TPopupMenu;
MyHandle:HWND;
FAutoAddIcon: Boolean;
r:NOTIFYICONDATA;
FHasAddIcon: Boolean;
FOnMouseDblClick: TMouseClickEvent;
procedure SetHint(const Value: String);
procedure SetIcon(const Value: TIcon);
procedure SetOnMouseClick(const Value: TMouseClickEvent);
procedure SetPopupMenu(const Value: TPopupMenu);
procedure SetAutoAddIcon(const Value: Boolean);
procedure SetOnMouseDblClick(const Value: TMouseClickEvent);
protected
procedure OnMessage(var msg:TMessage);
procedure MouseClick(IsRightButton:Boolean);
procedure MouseDblClick(IsRightButton:Boolean);
procedure Loaded;override;
function ModifyIcon:Boolean;
public
property HasAddIcon:Boolean read FHasAddIcon;
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure Assign(Source: TPersistent);override;
function AddIcon:Boolean;
function DeleteIcon:Boolean;
function ChangeIcon(AIcon:TIcon;AHint:String):Boolean;
published
property OnMouseClick:TMouseClickEvent read FOnMouseClick write SetOnMouseClick;
property OnMouseDblClick:TMouseClickEvent read FOnMouseDblClick write SetOnMouseDblClick;
property Icon:TIcon read FIcon write SetIcon;
property Hint:String read FHint write SetHint;
property PopupMenu:TPopupMenu read FPopupMenu write SetPopupMenu;
property AutoAddIcon:Boolean read FAutoAddIcon write SetAutoAddIcon default True;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Samples', [TTaskBarIcon]);
end;
{ TTaskBarIcon }
function TTaskBarIcon.AddIcon:Boolean;
begin
if FHasAddIcon then
begin
result:=False;
exit;
end;
r.cbSize:=sizeof(r);
r.Wnd:=MyHandle;
Randomize;
r.uID:=Random($FFFFFFFF);
r.uFlags:=NIF_ICON or NIF_MESSAGE or NIF_TIP;
r.uCallbackMessage:= WM_USER+5;
if FIcon.Empty then
r.hIcon:=Application.Icon.Handle
else
r.hIcon:=FIcon.Handle; {$warnings off}
strcopy(r.szTip,PAnsiChar(FHint));
if Shell_NotifyIcon(NIM_ADD,@r) then {$warnings on}
begin
FHasAddIcon:=True;
result:=True;
end
else
result:=False;
end;
procedure TTaskBarIcon.Assign(Source: TPersistent);
begin
if (Source<>nil) and (Source Is TTaskBarIcon) then
begin
FIcon.Assign((Source as TTaskBarIcon).Icon);
FHint:=(Source as TTaskBarIcon).Hint;
ModifyIcon;
end
else
inherited Assign(Source);
end;
constructor TTaskBarIcon.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FIcon:=TIcon.Create;
FAutoAddIcon:=True;
FHasAddIcon:=False;
MyHandle:= Classes.AllocateHWnd(OnMessage);
end;
function TTaskBarIcon.DeleteIcon:Boolean;
begin
if FHasAddIcon then
begin {$warnings off}
result:=Shell_NotifyIcon(NIM_Delete,@r); {$warnings on}
if result then
FHasAddIcon:=False;
end
else
result:=False;
end;
destructor TTaskBarIcon.Destroy;
begin
if FHasAddIcon then
DeleteIcon;
FIcon.Free;
Classes.DeallocateHWnd(MyHandle);
inherited;
end;
procedure TTaskBarIcon.Loaded;
begin
inherited;
if (Not(csDesigning in ComponentState)) and (FAutoAddIcon) then
AddIcon;
end;
function TTaskBarIcon.ModifyIcon: Boolean;
begin
if FHasAddIcon then
begin {$warnings off}
StrCopy(r.szTip,PAnsiChar(FHint)); {$warnings on}
if FIcon.Empty then
r.hIcon:=Application.Icon.Handle
else
r.hIcon:=FIcon.Handle; {$warnings off}
result:=Shell_NotifyIcon(NIM_MODIFY,@r); {$warnings on}
end
else
result:=False;
end;
function TTaskBarIcon.ChangeIcon(AIcon: TIcon; AHint:string): Boolean;
begin
if Not(FHasAddIcon) then
raise Exception.Create('必须先AddIcon');
if length(AHint)<=63 then
FHint:=AHint
else
raise Exception.Create('Hint的长度不能超过63');
FIcon.Assign(AIcon);
result:=ModifyIcon;
end;
procedure TTaskBarIcon.MouseClick(IsRightButton: Boolean);
begin
if FHasAddIcon then
begin
if (Assigned(FPopupMenu)) and (FPopupMenu.AutoPopup) then
if (FPopupMenu.TrackButton=tbLeftButton) xor (IsRightButton) then
FPopupMenu.Popup(Mouse.CursorPos.X,Mouse.CursorPos.Y);
if Assigned(FOnMouseClick) then
FOnMouseClick(Self,IsRightButton);
end;
end;
procedure TTaskBarIcon.MouseDblClick(IsRightButton: Boolean);
begin
if (FHasAddIcon) and (Assigned(FOnMouseDblClick)) then
FOnMouseDblClick(Self,IsRightButton);
end;
procedure TTaskBarIcon.OnMessage(var msg: TMessage);
begin
if msg.Msg<>WM_USER+5 then
msg.Result:=DefWindowProc(MyHandle, msg.Msg, msg.wParam, msg.lParam)
else
case msg.LParam of
WM_RBUTTONUP: MouseClick(True);
WM_LBUTTONUP: MouseClick(False);
WM_RBUTTONDBLCLK: MouseDblClick(True);
WM_LBUTTONDBLCLK: MouseDblClick(False);
end;
end;
procedure TTaskBarIcon.SetAutoAddIcon(const Value: Boolean);
begin
FAutoAddIcon := Value;
end;
procedure TTaskBarIcon.SetHint(const Value: String);
begin
if length(Value)>63 then
raise Exception.Create('Hint的长度不能超过64')
else
begin
FHint := Value;
ModifyIcon;
end;
end;
procedure TTaskBarIcon.SetIcon(const Value: TIcon);
begin
FIcon.Assign(Value);
ModifyIcon;
end;
procedure TTaskBarIcon.SetOnMouseClick(const Value: TMouseClickEvent);
begin
FOnMouseClick := Value;
end;
procedure TTaskBarIcon.SetOnMouseDblClick(const Value: TMouseClickEvent);
begin
FOnMouseDblClick := Value;
end;
procedure TTaskBarIcon.SetPopupMenu(const Value: TPopupMenu);
begin
FPopupMenu := Value;
end;
end.
Top
126楼 old_bonze (老和尚) 回复于 2004-09-08 18:22:53 得分 0
unit MD5;
//----------------------------------------------------------------------------
// MD5算法单元.
// 作者: old_bonze, 2004年7月26日
// 算法承袭自 RSA Data Security, INC. D5 Message-Digest Algorithm C语言版本.
//----------------------------------------------------------------------------
interface
uses
SysUtils, Classes;
const
S11 = 7;
S12 = 12;
S13 = 17;
S14 = 22;
S21 = 5;
S22 = 9;
S23 = 14;
S24 = 20;
S31 = 4;
S32 = 11;
S33 = 16;
S34 = 23;
S41 = 6;
S42 = 10;
S43 = 15;
S44 = 21;
CardinalSize = 4;
type
MD5_CTX = record
State : packed array [ 0..3 ] of Cardinal;
Count : packed array [ 0..1 ] of Cardinal;
Buffer : packed array [ 0..63 ] of char;
end;
PMD5_CTX = ^MD5_CTX;
PCardinal = ^Cardinal;
TPADDING = packed array [ 0..63 ] of char;
TMD5 = class
private
class procedure MD5MemCopy( Dest, Src : PChar; Cnt : Cardinal );
class procedure MD5MemSet( Dest : PChar; Val : Byte; Cnt : Cardinal );
class procedure MD5Init( context : PMD5_CTX );
class procedure MD5Update( context : PMD5_CTX; Input : PChar; InputLen : Cardinal );
class procedure MD5Final( Result : Pointer; context : PMD5_CTX );
class procedure MD5Transform( state : PCardinal; block : PChar );
class procedure Encode( output : PChar; input : PCardinal; len : Cardinal );
class procedure Decode( output : PCardinal; input : PChar; len : Cardinal );
class function F( x,y,z : Cardinal ) : Cardinal;
class function G( x,y,z : Cardinal ) : Cardinal;
class function H( x,y,z : Cardinal ) : Cardinal;
class function I( x,y,z : Cardinal ) : Cardinal;
class procedure FF( var a : Cardinal; b,c,d,x,s,ac : Cardinal );
class procedure GG( var a : Cardinal; b,c,d,x,s,ac : Cardinal );
class procedure HH( var a : Cardinal; b,c,d,x,s,ac : Cardinal );
class procedure II( var a : Cardinal; b,c,d,x,s,ac : Cardinal );
class function ROTATE_LEFT( a : Cardinal; s : Cardinal ) : Cardinal;
class function PADDING : TPADDING;
public
class procedure MD5Value( SrcStr : PChar; SrcLen : Cardinal; ResultPt : Pointer );
class function MD5String( SrcStr : PChar; SrcLen : Cardinal ) : String;
class function FormatMD5Result( ResultPT : Pointer ) : String;
end;
var
PADDINGData : TPADDING;
Initted : boolean = false;
implementation
{ TMD5 }
class function TMD5.PADDING : TPADDING;
var
i : integer;
begin
if not initted then begin
PADDINGData[0] := Chr($80);
for i:=1 to 63 do begin
PADDINGData[i] := Chr(0);
end;
initted := true;
end;
result := PADDINGData;
end;
class function TMD5.F( x,y,z : Cardinal ) : Cardinal;
begin
result := Cardinal( (x and y) or ( (not x) and z ) );
end;
class function TMD5.G( x,y,z : Cardinal ) : Cardinal;
begin
result := Cardinal( (x and z) or ( y and (not z)) );
end;
class function TMD5.H( x,y,z : Cardinal ) : Cardinal;
begin
result := Cardinal( x xor y xor z );
end;
class function TMD5.I( x,y,z : Cardinal ) : Cardinal;
begin
result := Cardinal( y xor ( x or (not z) ) );
end;
class procedure TMD5.FF( var a : Cardinal; b,c,d,x,s,ac : Cardinal );
begin
a := a + F(b,c,d) + x + ac;
a := ROTATE_LEFT( a, s );
a := a + b;
end;
class procedure TMD5.GG( var a : Cardinal; b,c,d,x,s,ac : Cardinal );
begin
a := a + G(b,c,d) + x + ac;
a := ROTATE_LEFT( a, s );
a := a + b;
end;
class procedure TMD5.HH( var a : Cardinal; b,c,d,x,s,ac : Cardinal );
begin
a := a + H(b,c,d) + x + ac;
a := ROTATE_LEFT( a , s );
a := a + b;
end;
class procedure TMD5.II( var a : Cardinal; b,c,d,x,s,ac : Cardinal );
begin
a := a + I(b,c,d) + x + ac;
a := ROTATE_LEFT( a , s );
a := a + b;
end;
class function TMD5.ROTATE_LEFT( a : Cardinal; s : Cardinal ) : Cardinal;
begin
result := Cardinal( ( a shl s ) or ( a shr (32-s)) );
end;
class procedure TMD5.Decode(output: PCardinal; input: PChar;
len: Cardinal);
var
j : Cardinal;
begin
j := 0;
while j<len do begin
output^ := Cardinal( Ord(input^) );
input := input + 1;
output^ := output^ or ( Cardinal( Ord(input^) ) shl 8 );
input := input + 1;
output^ := output^ or ( Cardinal( Ord(input^) ) shl 16 );
input := input + 1;
output^ := output^ or ( Cardinal( Ord(input^) ) shl 24 );
input := input + 1;
j := j+4;
output := PCardinal( pchar(output) + CardinalSize );
end;
end;
class procedure TMD5.Encode(output: PChar; input: PCardinal;
len: Cardinal);
var
j : Cardinal;
begin
j := 0;
while j<len do begin
output^ := Chr(Byte(input^ and $FF)) ;
output := output + 1;
output^ := Chr(Byte( ( input^ shr 8 ) and $FF )) ;
output := output + 1;
output^ := Chr(Byte( ( input^ shr 16 ) and $FF )) ;
output := output + 1;
output^ := Chr(Byte( ( input^ shr 24 ) and $FF )) ;
output := output + 1;
j := j+4;
input := PCardinal( pchar(input) + CardinalSize );
end;
end;
class procedure TMD5.MD5Final(Result: Pointer; context: PMD5_CTX);
var
bits : packed array [0..7] of char;
index, padLen : Cardinal;
pad : TPADDING;
begin
pad := PADDING;
Encode( @bits[0], PCardinal( @context^.Count[0] ),8 );
index := Cardinal( ( context^.Count[0] shr 3 ) and $3F );
if index < 56 then
padLen := 56 - index
else
padLen := 120 - index;
MD5Update( context, @pad[0], padLen );
MD5Update( context, @bits[0], 8 );
Encode( PChar( Result ), PCardinal( @context^.State[0] ), 16 );
MD5MemSet( PChar( context ), 0, sizeof( context^ ) );
end;
class procedure TMD5.MD5Init(context: PMD5_CTX);
begin
context^.State[0] := $67452301;
context^.State[1] := $efcdab89;
context^.State[2] := $98badcfe;
context^.State[3] := $10325476;
context^.Count[0] := 0;
context^.Count[1] := 0;
end;
class procedure TMD5.MD5MemCopy(Dest, Src: PChar; Cnt: Cardinal);
var
i : Cardinal;
begin
for i:=0 to Cnt-1 do begin
Dest^ := Src^;
Dest := Dest + 1;
Src := Src + 1;
end;
end;
class procedure TMD5.MD5MemSet(Dest: PChar; Val: Byte; Cnt: Cardinal);
var
i : Cardinal;
begin
for i:=0 to Cnt-1 do begin
Dest^ := Chr(Val);
Dest := Dest + 1;
end;
end;
class function TMD5.MD5String(SrcStr: PChar; SrcLen: Cardinal): String;
var
rslt : packed array [ 0..15 ] of Byte;
begin
MD5Value( SrcStr, SrcLen, @rslt[0] );
Result := FormatMD5Result( @rslt[0] );
end;
class procedure TMD5.MD5Transform(state: PCardinal; block: PChar);
var
a,b,c,d : Cardinal;
x : packed array [ 0..15 ] of Cardinal;
p : PCardinal;
begin
p := state;
a := p^;
p := PCardinal( pchar(p) + CardinalSize );
b := p^;
p := PCardinal( pchar(p) + CardinalSize );
c := p^;
p := PCardinal( pchar(p) + CardinalSize );
d := p^;
Decode( PCardinal(@x[0]),block,64 );
FF (a, b, c, d, x[ 0], S11, $d76aa478); { 1 }
FF (d, a, b, c, x[ 1], S12, $e8c7b756); { 2 }
FF (c, d, a, b, x[ 2], S13, $242070db); { 3 }
FF (b, c, d, a, x[ 3], S14, $c1bdceee); { 4 }
FF (a, b, c, d, x[ 4], S11, $f57c0faf); { 5 }
FF (d, a, b, c, x[ 5], S12, $4787c62a); { 6 }
FF (c, d, a, b, x[ 6], S13, $a8304613); { 7 }
FF (b, c, d, a, x[ 7], S14, $fd469501); { 8 }
FF (a, b, c, d, x[ 8], S11, $698098d8); { 9 }
FF (d, a, b, c, x[ 9], S12, $8b44f7af); { 10 }
FF (c, d, a, b, x[10], S13, $ffff5bb1); { 11 }
FF (b, c, d, a, x[11], S14, $895cd7be); { 12 }
FF (a, b, c, d, x[12], S11, $6b901122); { 13 }
FF (d, a, b, c, x[13], S12, $fd987193); { 14 }
FF (c, d, a, b, x[14], S13, $a679438e); { 15 }
FF (b, c, d, a, x[15], S14, $49b40821); { 16 }
GG (a, b, c, d, x[ 1], S21, $f61e2562); { 17 }
GG (d, a, b, c, x[ 6], S22, $c040b340); { 18 }
GG (c, d, a, b, x[11], S23, $265e5a51); { 19 }
GG (b, c, d, a, x[ 0], S24, $e9b6c7aa); { 20 }
GG (a, b, c, d, x[ 5], S21, $d62f105d); { 21 }
GG (d, a, b, c, x[10], S22, $2441453); { 22 }
GG (c, d, a, b, x[15], S23, $d8a1e681); { 23 }
GG (b, c, d, a, x[ 4], S24, $e7d3fbc8); { 24 }
GG (a, b, c, d, x[ 9], S21, $21e1cde6); { 25 }
GG (d, a, b, c, x[14], S22, $c33707d6); { 26 }
GG (c, d, a, b, x[ 3], S23, $f4d50d87); { 27 }
GG (b, c, d, a, x[ 8], S24, $455a14ed); { 28 }
GG (a, b, c, d, x[13], S21, $a9e3e905); { 29 }
GG (d, a, b, c, x[ 2], S22, $fcefa3f8); { 30 }
GG (c, d, a, b, x[ 7], S23, $676f02d9); { 31 }
GG (b, c, d, a, x[12], S24, $8d2a4c8a); { 32 }
HH (a, b, c, d, x[ 5], S31, $fffa3942); { 33 }
HH (d, a, b, c, x[ 8], S32, $8771f681); { 34 }
HH (c, d, a, b, x[11], S33, $6d9d6122); { 35 }
HH (b, c, d, a, x[14], S34, $fde5380c); { 36 }
HH (a, b, c, d, x[ 1], S31, $a4beea44); { 37 }
HH (d, a, b, c, x[ 4], S32, $4bdecfa9); { 38 }
HH (c, d, a, b, x[ 7], S33, $f6bb4b60); { 39 }
HH (b, c, d, a, x[10], S34, $bebfbc70); { 40 }
HH (a, b, c, d, x[13], S31, $289b7ec6); { 41 }
HH (d, a, b, c, x[ 0], S32, $eaa127fa); { 42 }
HH (c, d, a, b, x[ 3], S33, $d4ef3085); { 43 }
HH (b, c, d, a, x[ 6], S34, $4881d05); { 44 }
HH (a, b, c, d, x[ 9], S31, $d9d4d039); { 45 }
HH (d, a, b, c, x[12], S32, $e6db99e5); { 46 }
HH (c, d, a, b, x[15], S33, $1fa27cf8); { 47 }
HH (b, c, d, a, x[ 2], S34, $c4ac5665); { 48 }
II (a, b, c, d, x[ 0], S41, $f4292244); { 49 }
II (d, a, b, c, x[ 7], S42, $432aff97); { 50 }
II (c, d, a, b, x[14], S43, $ab9423a7); { 51 }
II (b, c, d, a, x[ 5], S44, $fc93a039); { 52 }
II (a, b, c, d, x[12], S41, $655b59c3); { 53 }
II (d, a, b, c, x[ 3], S42, $8f0ccc92); { 54 }
II (c, d, a, b, x[10], S43, $ffeff47d); { 55 }
II (b, c, d, a, x[ 1], S44, $85845dd1); { 56 }
II (a, b, c, d, x[ 8], S41, $6fa87e4f); { 57 }
II (d, a, b, c, x[15], S42, $fe2ce6e0); { 58 }
II (c, d, a, b, x[ 6], S43, $a3014314); { 59 }
II (b, c, d, a, x[13], S44, $4e0811a1); { 60 }
II (a, b, c, d, x[ 4], S41, $f7537e82); { 61 }
II (d, a, b, c, x[11], S42, $bd3af235); { 62 }
II (c, d, a, b, x[ 2], S43, $2ad7d2bb); { 63 }
II (b, c, d, a, x[ 9], S44, $eb86d391); { 64 }
p := state;
p^ := p^ + a;
p := PCardinal( pchar(p) + CardinalSize );
p^ := p^ + b;
p := PCardinal( pchar(p) + CardinalSize );
p^ := p^ + c;
p := PCardinal( pchar(p) + CardinalSize );
p^ := p^ + d;
MD5MemSet( pchar( @x[0] ),0,16*CardinalSize );
end;
class procedure TMD5.MD5Update(context: PMD5_CTX; Input: PChar;
InputLen: Cardinal);
var
i, index, partLen : Cardinal;
begin
index := Cardinal(( context^.Count[0] shr 3 ) and $3F );
context^.Count[0] := context^.Count[0] + (inputLen shl 3);
if context^.Count[0] < ( inputLen shl 3 ) then
context^.Count[1] := context^.Count[1] + 1;
context^.Count[1] := context^.Count[1] + ( inputLen shr 29 );
partLen := 64 - index;
if InputLen >= partLen then begin
MD5MemCopy( PChar( @context^.Buffer[index] ), Input, partLen );
MD5Transform( PCardinal(@context^.State[0]), @context^.Buffer[0] );
i := partLen;
while i+63 < inputLen do begin
MD5Transform( PCardinal( @context^.State[0] ), Input + i );
i := i + 64;
end;
index := 0;
end
else begin
i := 0;
end;
if inputLen > i then
MD5MemCopy( PChar(@context^.Buffer[index]), Input+i, InputLen-i );
end;
class procedure TMD5.MD5Value(SrcStr: PChar; SrcLen: Cardinal;
ResultPT: Pointer);
var
context : MD5_CTX;
begin
MD5Init( @context );
MD5Update( @context, SrcStr, SrcLen );
MD5Final( ResultPT, @context );
end;
class function TMD5.FormatMD5Result(ResultPT: Pointer): String;
var
rs : String;
p : pchar;
i : integer;
begin
rs := '';
p := pchar(ResultPT);
for i:=0 to 15 do begin
rs := rs + Format('%.2x', [Ord(p^)]);
p := p + 1;
end;
result := lowercase( rs );
end;
end.
Top
147楼 ksaiy (阳光总在风雨后) 回复于 2004-10-24 00:12:36 得分 0
unit Crc32;
interface
uses Windows;
const
Table: array[0..255] of DWORD =
($00000000, $77073096, $EE0E612C, $990951BA,
$076DC419, $706AF48F, $E963A535, $9E6495A3,
$0EDB8832, $79DCB8A4, $E0D5E91E, $97D2D988,
$09B64C2B, $7EB17CBD, $E7B82D07, $90BF1D91,
$1DB71064, $6AB020F2, $F3B97148, $84BE41DE,
$1ADAD47D, $6DDDE4EB, $F4D4B551, $83D385C7,
$136C9856, $646BA8C0, $FD62F97A, $8A65C9EC,
$14015C4F, $63066CD9, $FA0F3D63, $8D080DF5,
$3B6E20C8, $4C69105E, $D56041E4, $A2677172,
$3C03E4D1, $4B04D447, $D20D85FD, $A50AB56B,
$35B5A8FA, $42B2986C, $DBBBC9D6, $ACBCF940,
$32D86CE3, $45DF5C75, $DCD60DCF, $ABD13D59,
$26D930AC, $51DE003A, $C8D75180, $BFD06116,
$21B4F4B5, $56B3C423, $CFBA9599, $B8BDA50F,
$2802B89E, $5F058808, $C60CD9B2, $B10BE924,
$2F6F7C87, $58684C11, $C1611DAB, $B6662D3D,
$76DC4190, $01DB7106, $98D220BC, $EFD5102A,
$71B18589, $06B6B51F, $9FBFE4A5, $E8B8D433,
$7807C9A2, $0F00F934, $9609A88E, $E10E9818,
$7F6A0DBB, $086D3D2D, $91646C97, $E6635C01,
$6B6B51F4, $1C6C6162, $856530D8, $F262004E,
$6C0695ED, $1B01A57B, $8208F4C1, $F50FC457,
$65B0D9C6, $12B7E950, $8BBEB8EA, $FCB9887C,
$62DD1DDF, $15DA2D49, $8CD37CF3, $FBD44C65,
$4DB26158, $3AB551CE, $A3BC0074, $D4BB30E2,
$4ADFA541, $3DD895D7, $A4D1C46D, $D3D6F4FB,
$4369E96A, $346ED9FC, $AD678846, $DA60B8D0,
$44042D73, $33031DE5, $AA0A4C5F, $DD0D7CC9,
$5005713C, $270241AA, $BE0B1010, $C90C2086,
$5768B525, $206F85B3, $B966D409, $CE61E49F,
$5EDEF90E, $29D9C998, $B0D09822, $C7D7A8B4,
$59B33D17, $2EB40D81, $B7BD5C3B, $C0BA6CAD,
$EDB88320, $9ABFB3B6, $03B6E20C, $74B1D29A,
$EAD54739, $9DD277AF, $04DB2615, $73DC1683,
$E3630B12, $94643B84, $0D6D6A3E, $7A6A5AA8,
$E40ECF0B, $9309FF9D, $0A00AE27, $7D079EB1,
$F00F9344, $8708A3D2, $1E01F268, $6906C2FE,
$F762575D, $806567CB, $196C3671, $6E6B06E7,
$FED41B76, $89D32BE0, $10DA7A5A, $67DD4ACC,
$F9B9DF6F, $8EBEEFF9, $17B7BE43, $60B08ED5,
$D6D6A3E8, $A1D1937E, $38D8C2C4, $4FDFF252,
$D1BB67F1, $A6BC5767, $3FB506DD, $48B2364B,
$D80D2BDA, $AF0A1B4C, $36034AF6, $41047A60,
$DF60EFC3, $A867DF55, $316E8EEF, $4669BE79,
$CB61B38C, $BC66831A, $256FD2A0, $5268E236,
$CC0C7795, $BB0B4703, $220216B9, $5505262F,
$C5BA3BBE, $B2BD0B28, $2BB45A92, $5CB36A04,
$C2D7FFA7, $B5D0CF31, $2CD99E8B, $5BDEAE1D,
$9B64C2B0, $EC63F226, $756AA39C, $026D930A,
$9C0906A9, $EB0E363F, $72076785, $05005713,
$95BF4A82, $E2B87A14, $7BB12BAE, $0CB61B38,
$92D28E9B, $E5D5BE0D, $7CDCEFB7, $0BDBDF21,
$86D3D2D4, $F1D4E242, $68DDB3F8, $1FDA836E,
$81BE16CD, $F6B9265B, $6FB077E1, $18B74777,
$88085AE6, $FF0F6A70, $66063BCA, $11010B5C,
$8F659EFF, $F862AE69, $616BFFD3, $166CCF45,
$A00AE278, $D70DD2EE, $4E048354, $3903B3C2,
$A7672661, $D06016F7, $4969474D, $3E6E77DB,
$AED16A4A, $D9D65ADC, $40DF0B66, $37D83BF0,
$A9BCAE53, $DEBB9EC5, $47B2CF7F, $30B5FFE9,
$BDBDF21C, $CABAC28A, $53B39330, $24B4A3A6,
$BAD03605, $CDD70693, $54DE5729, $23D967BF,
$B3667A2E, $C4614AB8, $5D681B02, $2A6F2B94,
$B40BBE37, $C30C8EA1, $5A05DF1B, $2D02EF8D);
procedure CalcCRC32(FileName: string; var CRC32: DWORD);
implementation
procedure CalcCRC32(FileName: string; var CRC32: DWORD);
var
F: file;
BytesRead: DWORD;
Buffer: array[1..65521] of Byte;
i: Word;
begin
FileMode := 0;
CRC32 := $ffffffff;
{$I-}
AssignFile(F, FileName);
Reset(F, 1);
if IOResult = 0 then
begin
repeat
BlockRead(F, Buffer, SizeOf(Buffer), BytesRead);
for i := 1 to BytesRead do
CRC32 := (CRC32 shr 8) xor Table[Buffer[i] xor (CRC32 and $000000FF)];
until BytesRead = 0;
end;
CloseFile(F);
{$I+}
CRC32 := not CRC32;
end;
end.
anti-Debug代码：
作者：ksaiy
unit Anti;
interface
uses
Messages,Classes, Windows,TlHelp32,SysUtils,Dialogs;
Function SofticeLoaded:Boolean;
Procedure Anti_DeDe();
Function RegLoaded:Boolean;
Function FileLoaded:Boolean;
Function SoftIceXPLoaded:Boolean;
Function IsBPX(addr:Pointer):Boolean;
Function IsDebug():Boolean;
implementation
////////////////////////////////////////////////////////////////////////////////
//Anti-Debug
Function SoftIceLoaded: Boolean; //检测Win98下SoftICE
var
hFile: Thandle;
Begin
Result := false;
hFile := CreateFileA('//./SICE', GENERIC_READ or GENERIC_WRITE,
FILE_SHARE_READ or FILE_SHARE_WRITE, nil, OPEN_EXISTING,
FILE_ATTRIBUTE_NORMAL, 0);
if( hFile <> INVALID_HANDLE_VALUE ) then begin
CloseHandle(hFile);
Result := TRUE;
end;
End;
Function SoftIceXPLoaded:Boolean;//检测Win2000/XP下的SoftIce
var
mark:Integer;
YesInt,NoInt:Integer;
begin
YesInt:=0;NoInt:=0;
mark:=0;
asm
push offset @handler
push dword ptr fs:[0]
mov dword ptr fs:[0],esp
xor eax,eax
int 1
inc eax
inc eax
pop dword ptr fs:[0]
add esp,4
or eax,eax
jz @found
cmp mark, 0
jnz @found
jmp @Nofound
@handler:
mov ebx,[esp+0ch]
add dword ptr [ebx+0b8h],02h
mov ebx,[esp+4]
cmp [ebx], 80000004h
jz @Table
inc mark
@Table:
xor eax,eax
ret
@found:
mov YesInt,1
@Nofound:
mov NoInt,1
end;
if Yesint=1 then
Result:=True;
if NoInt=1 then
Result:=False;
end;
////////////////////////////////////////////////////////////////////////////////
//Anti-Monitor
Function DumpLoaded: Boolean; //检测RegMON;
var
hFile: Thandle;
Begin
Result:= false;
hFile := FindWindow(nil,'ProcDump32 (C) 1998, 1999, 2000 G-RoM, Lorian & Stone');
if( hFile <> 0 ) then
begin
Result:= TRUE;
end;
End;
Function RegLoaded: Boolean; //检测RegMON;
var
hFile: Thandle;
Begin
Result:= false;
hFile := FindWindow(nil,'Registry Monitor - Sysinternals: www.sysinternals.com');
if( hFile <> 0 ) then
begin
Result:= TRUE;
end;
End;
Function FileLoaded: Boolean; //检测FileMON;
var
hFile: Thandle;
Begin
Result:= false;
hFile := FindWindow(nil,'File Monitor - Sysinternals: www.sysinternals.com');
if( hFile <> 0 ) then
begin
Result:= TRUE;
end;
End;
////////////////////////////////////////////////////////////////////////////////
//Anti-loader
Function IsDebug():Boolean; //检测调试器;
var
YInt,NInt:Integer;
begin
asm
mov eax,fs:[30h]
movzx eax,byte ptr[eax+2h]
or al,al
jz @No
jnz @Yes
@No:
mov NInt,1
@Yes:
Mov YInt,1
end;
if YInt=1 then
Result:=True;
if NInt=1 then
Result:=False;
end;
////////////////////////////////////////////////////////////////////////////////
//DetectBreakpoint
Function IsBPX(addr:Pointer):Boolean;//防范BPX断点
var
YInt,NInt:Integer;
begin
asm
mov esi,addr
mov al,[esi]
cmp al,$CC
je @Yes
jne @No
@Yes:
mov YInt,1
@No:
mov NInt,1
end;
if YInt=1 then
Result:=True;
if NInt=1 then
Result:=False;
end;
Procedure Anti_DeDe();//检测DEDE；
var
DeDeHandle:THandle;
i:integer;
begin
DeDeHandle:=FindWindow(nil,chr($64)+chr($65)+chr($64)+chr($65));
if DeDeHandle<>0 then
begin
For i:=1 to 4500 do
SendMessage(DeDeHandle,WM_CLOSE,0,0);
end;
end;
end.
Top
149楼 ksaiy (阳光总在风雨后) 回复于 2004-10-24 00:14:29 得分 0
procedure TKenFrm.FormCreate(Sender: TObject);
var
Reg:TRegistry;
RInt,SizeInt:Integer;
FileStr,UNStr,SNStr,RStr1,RStr2:String;
SumInt:Integer;
Str:String;
DllCrcStr,DllStr:String;
begin
Reg:=TRegistry.Create;
Reg.RootKey:=HKEY_LOCAL_MACHINE;
DllCrCStr:='E8A316E366BC9B7C'; //这个是加过壳的dll的CRC校验值,进行了Des加密.
DllStr:=ExtractFilePath(Application.ExeName)+'/Ken.dll';
if ShlStr(FileCrc32(DllStr))<>ShlStr(KDD(DllCrCStr,'wwwksaiycom')) then//校验dll失败后关闭计算机.
// WinExit(EWX_SHUTDOWN or EWX_POWEROFF);//关机函数;调试的时候把这行注释掉，发布的时候激活此行。
ShowMessage('校验失败！');
{
在程序目录下提供了两个DLL文件，由于DLL进行了加壳那么在调试的时候就会出现问题，故提供一个加过壳的DLL和一个未
加过壳的DLL，怎么区分这两个DLL呢？文件大的那个是加过壳的，文件小的那个是未加过克的，调试的时候用文件小的那个DLL，
也就是把DLL名字改为Ken.dll,分布您的软件的时候请把大的那个DLL的名字改为Ken.dll一起随程序发布。
在上面对Ken.dll进行CRC校验，也就是说如果加壳的DLL被脱壳或替换，那么进行CRC校验不正确，这样就可以进行你要自己的
操作了，比如关闭计算机。
在这里我仅对DLL进行了校验，还没有对程序本上校验，不过方法是一样的，下面给出方法：
首先把自己的软件调试好以后，用FileCrc32取得主程序的CRC校验值，在对这个校验值进行加密，然后把密加结果存放到一个文
件里（这里我是举例说明，你也可以把它写到可执行文件里去，源码可以到我们的站点上下载），那么在文件的create事件里用
FileCrc32取得当前文件的CRC值，再把您存放在文件里的CRC值取出来解密后进行比较，如果正确那么就执行文件，如果不正确
就执行你自己的操作，比如关闭计算机。
这里我只是提供了方法，详细的模块我在我们的站点上有，但那是会员模块。您可以考虑成为我们的会员。具体可以参看我们的
网站上相关资料。
我们的网站：http://www.ksaiy.com
专业加密论坛：http://www.ksaiy.com/bbs
技术支持QQ：40188696 UC：934155
作者：ksaiy
}
Anti_DeDe();//检测DeDe;
SumInt:=0;
Edit2.Text:=GetHDID;//取得系列号，每台计算机的系列号是唯一的；
//Anti-Debug;
if IsSoftIce95Loaded or IsSoftIceNTLoaded or IsTRWLoaded or IsTRWLoaded or IsTRW2000Loaded or IsRegMONLoaded or IsFileMONLoaded or IsBW2000Loaded then
begin
PostMessage(Application.Handle,WM_CLOSE,0,0);//这里是指当发现调试工具的时候关闭程序本身，也可以设置为关闭计算机；
end;
//程序自校验；
// RInt:=160000;//加壳后的文件大小，壳在压缩包里提供了FSG壳，这个文件的大小你可以加壳后来进行修改，然后在编译的你的软件再加壳就可以发布了；
//加壳方法：先打开FSG，然后选择你要加壳的文件即可。
// FileStr:=ExpandFileName(ExtractFilePath(Application.ExeName)+'/Ken.exe');//这里写上自己的注册文件名；
// if Anti_Self(Rint,FileStr)=True then
// PostMessage(Application.Handle,WM_CLOSE,0,0);
if reg.OpenKey('/SoftWare/Microsoft/KEN',True) then
begin
RStr1:=Reg.ReadString('UN');
RStr2:=Reg.ReadString('SN');
end;
reg.CloseKey;
if (RStr1<>'') and (RStr2<>'') then
begin
UNStr:=KDD(RStr1,'shihongchun');
SNStr:=KDD(RStr2,'shihongchun');
if ShlStr(SNStr)=ShlStr(RightStr(KXEN(Edit2.Text),20)) then //进行非明码比较；
begin
//下面是注册成功你要做的事情，但千万不要出现"注册成功字样"，你可以把某些功能给出来。
Label1.Enabled:=False;
Edit1.Enabled:=False;
Button1.Enabled:=False;
end
else
begin//对软件进行次数限制;
if Reg.OpenKey('/SoftWare/Microsoft/KEN',True) then
Str:=Reg.ReadString('KENC');
Reg.CloseKey;
if Str='' then//判断次数是否为空，如果为空那么写入1；
begin
if Reg.OpenKey('/SoftWare/Microsoft/KEN',True) then
Reg.WriteString('KENC','1919F0CF019DBB3E'); //1919F0CF019DBB3E是经过加密后的字符串，原值为1；
Reg.CloseKey;
end
else
begin
SumInt:=StrToInt(KDD(Str,'shihongchun')); //读取次数
SumInt:=SumInt+StrToInt(KDD('1919F0CF019DBB3E','shihongchun'));//对次数进行相加；
if SumInt>StrToInt(KDD('728DA73436100E6C','shihongchun')) then //判断次数是否等于30次；
begin//下面可以设置次数到期限制一些功能；
MessageBox(KENFrm.Handle,'您好！软件的使用次数已到，请注册正式版！','注册提示',MB_OK+MB_ICONINFORMATION);
end
else
begin//如果次数不到期，那么继续对次数的植进行相加；
if Reg.OpenKey('/SoftWare/Microsoft/KEN',True) then
Reg.WriteString('KENC',KED(IntToStr(SumInt),'shihongchun'));
Reg.CloseKey;
end;
end;
end;
end
else
begin
if Reg.OpenKey('/SoftWare/Microsoft/KEN',True) then
Str:=Reg.ReadString('KENC');
Reg.CloseKey;
if Str='' then
begin
if Reg.OpenKey('/SoftWare/Microsoft/KEN',True) then
Reg.WriteString('KENC','1919F0CF019DBB3E');
Reg.CloseKey;
end
else
begin
SumInt:=StrToInt(KDD(Str,'shihongchun'));
SumInt:=SumInt+StrToInt(KDD('1919F0CF019DBB3E','shihongchun'));
if SumInt>StrToInt(KDD('728DA73436100E6C','shihongchun')) then
begin
MessageBox(KENFrm.Handle,'您好！软件的使用次数已到，请注册正式版！','注册提示',MB_OK+MB_ICONINFORMATION);
end
else
begin
if Reg.OpenKey('/SoftWare/Microsoft/KEN',True) then
Reg.WriteString('KENC',KED(IntToStr(SumInt),'shihongchun'));
Reg.CloseKey;
end;
end;
end;
end;
procedure TKenFrm.Button1Click(Sender: TObject);
var
Reg:TRegistry;
begin
Reg:=TRegistry.Create;
reg.RootKey:=HKEY_LOCAL_MACHINE;
if Edit1.Text='' then
MessageBox(KENFrm.handle,'用户名不能为空，请填写完整！','注册提示',MB_OK+MB_ICONINFORMATION)
else
begin
if Edit3.Text<>'' then
begin
if reg.OpenKey('/SoftWare/Microsoft/KEN',True) then
begin
reg.WriteString('UN',KED(Edit1.Text,'shihongchun'));
reg.WriteString('SN',KED(Edit3.Text,'shihongchun'));
end;
reg.CloseKey;
MessageBox(KENFrm.handle,'请重新启动程序来进行注册码校验！','注册提示',MB_OK+MB_ICONINFORMATION);
end
else
MessageBox(KENFrm.handle,'注册码不能为空，请填写完整！','注册提示',MB_OK+MB_ICONINFORMATION)
end;
end;
Top
150楼 metro () 回复于 2004-10-24 10:37:57 得分 0
up!
Top
151楼 yuzhantao (和女朋友一起去养狗) 回复于 2004-10-24 11:19:54 得分 0
估计有不少人都不要意思把自己的拿出来吧
我也是，觉得没有什么是精彩的，怕人笑话，还是收藏吧
Top
152楼 ThenLong (完美组合=Delphi/C++) 回复于 2004-10-24 11:27:56 得分 0
// WinExit(EWX_SHUTDOWN or EWX_POWEROFF);//关机函数;调试的时候把这行注释掉，发布的时候激活此行。
建议使用
{$IF DEFINE DEBUG}
ShowMessage('DEBUG');
{$else}
ShowMessage('NOT DEBUG');
{$IFEND}
{ ***************可以实现类似QQ窗体的隐藏效果******************* }
{ Design: Kevin }
unit QQForm;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ExtCtrls, Math;
{$R QQfrm.res}
type
TQQForm = class(TComponent)
private
{ Private declarations }
fActive:Boolean;
fOldWndMethod:TWndMethod;
fForm:TForm;
ftimer:TTimer;
fAnchors: TAnchors;
protected
{ Protected declarations }
public
{ Public declarations }
constructor Create(AOwner:TComponent); override;
destructor Destroy; override;
procedure WndProc(var Message: TMessage);
procedure WMMoving(var Msg: TMessage);
procedure fOnTimer(Sender: TObject);
function FindParHWMD(Pos :TPoint):THandle;
published
{ Published declarations }
property Active:boolean read fActive write fActive;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Kevin', [TQQForm]);
end;
{ TQQForm }
constructor TQQForm.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
fActive:=True;
fTimer:=TTimer.Create(self);
fForm:=TForm(AOwner);
fForm.FormStyle := fsStayOnTop;
fTimer.Enabled := True;
fTimer.OnTimer := fOnTimer;
fTimer.Interval := 200;
fOldWndMethod:=fForm.WindowProc;
fForm.WindowProc:=WndProc;
end;
destructor TQQForm.Destroy;
begin
FreeAndNil(fTimer);
fForm.WindowProc:=fOldWndMethod;
inherited Destroy;
end;
function TQQForm.FindParHWMD(Pos: TPoint): THandle;
var
WControl :TWinControl;
begin
WControl := FindVCLWindow(Pos);
if WControl <> nil then
begin
while not (WControl.Parent = nil) do
begin
WControl := WControl.Parent;
end;
Result := WControl.Handle;
end else Result := 0;
end;
procedure TQQForm.fOnTimer(Sender: TObject);
const
coffset = 3;
var
ParHandle :THandle;
begin
ParHandle := FindParHWMD(Mouse.CursorPos);
if ParHandle = fForm.Handle then
begin
if akLeft in FAnchors then fForm.Left := 0;
if akTop in FAnchors then fForm.Top := 0;
if akRight in FAnchors then fForm.Left := Screen.Width - fForm.Width;
if akBottom in FAnchors then fForm.Top := Screen.Height - fForm.Height;
end else
begin
if akLeft in FAnchors then fForm.Left := -fForm.width + coffset;
if akTop in FAnchors then fForm.Top := -fForm.Height + coffset;
if akRight in FAnchors then fForm.Left := Screen.Width - coffset;
if akBottom in FAnchors then fForm.Top := Screen.Height - coffset;
end;
end;
procedure TQQForm.WMMoving(var Msg: TMessage);
begin
inherited;
with PRect(msg.LParam)^ do
begin
Left := Min(Max(0,Left),Screen.Width - fForm.Width);
Top := Min(Max(0,Top),Screen.Height - fForm.Height);
Right := Min(Max(fForm.Width,Right),Screen.Width);
Bottom := Min(Max(fForm.Height,Bottom),Screen.Height);
FAnchors := [];
if Left = 0 then Include(FAnchors,akLeft);
if Right = Screen.Width then Include(FAnchors,akRight);
if (Top = 0) and (Left <> 0) and (Right <> Screen.Width) then
begin
Include(FAnchors,akTop);
end else
if Left = 0 then
begin
Include(FAnchors,akLeft);
end else
if Right = Screen.Width then
begin
Include(FAnchors,akRight);
end;
if Bottom = Screen.Height then Include(FAnchors,akBottom);
fTimer.Enabled := FAnchors <> [];
end;
end;
procedure TQQForm.WndProc(var Message: TMessage);
begin
if not fActive then
begin
fOldwndMethod(Message);
Exit;
end;
if (CsDesigning in ComponentState) then fOldwndMethod(Message)
else
case Message.Msg of
WM_MOVING : WMMoving(Message);
else fOldwndMethod(Message);
end;
end;
end.
在Delphi中用拼音首字符序列来实现检索功能
作者：夏昆 教程来源：网络 点击数：14 更新时间：2004-11-10 【字体：小 大】 热
在日常工作和生活中我们经常使用电子记事本查找个人通讯录信息，或在单位的应用程序中查询客户档案或业务资料，这个过程中往往需要输入大量的汉字信息，对于熟悉计算机的人这已经是一件头疼的事，那些不太熟悉计算机或根本不懂汉字输入的用户简直就望而生畏。作为对数据检索技术的一种新的尝试，作者探索使用汉字拼音的首字符序列作为检索关键字，这样，用户不必使用汉字，只须简单地键入要查询信息的每个汉字的拼音首字符即可。比如你想查找关键字“中国人民银行”，你只需要输入“zgrmyh”。作者希望通过下面的例子，为广大计算机同行起一个抛砖引玉的作用，让我们开发的程序更加便捷、好用。
---- 原理很简单，找出汉字表中拼音首字符分别为“A”至“Z”的汉字内码范围，这样，对于要检索的汉字只需要检查它的内码位于哪一个首字符的范围内，就可以判断出它的拼音首字符。
---- 程序更简单，包括3个控件：一个列表存放着所有待检索的信息；一个列表用于存放检索后的信息；一个编辑框用于输入检索关键字（即拼音首字符序列）。详细如下：
---- 1．进入Delphi创建一个新工程：Project1
---- 2．在Form1上创建以下控件并填写属性：
控件类型 属性名称 属性值
Edit Name Search
ListBox Name SourceList
Items 输入一些字符串，如姓名等，用于提供检索数据
ListBox Name ResultList
---- 3．键入以下两个函数
// 获取指定汉字的拼音索引字母，如：“汉”的索引字母是“H”
function GetPYIndexChar( hzchar:string):char;
begin
case WORD(hzchar[1]) shl 8 + WORD(hzchar[2]) of
$B0A1..$B0C4 : result := 'A';
$B0C5..$B2C0 : result := 'B';
$B2C1..$B4ED : result := 'C';
$B4EE..$B6E9 : result := 'D';
$B6EA..$B7A1 : result := 'E';
$B7A2..$B8C0 : result := 'F';
$B8C1..$B9FD : result := 'G';
$B9FE..$BBF6 : result := 'H';
$BBF7..$BFA5 : result := 'J';
$BFA6..$C0AB : result := 'K';
$C0AC..$C2E7 : result := 'L';
$C2E8..$C4C2 : result := 'M';
$C4C3..$C5B5 : result := 'N';
$C5B6..$C5BD : result := 'O';
$C5BE..$C6D9 : result := 'P';
$C6DA..$C8BA : result := 'Q';
$C8BB..$C8F5 : result := 'R';
$C8F6..$CBF9 : result := 'S';
$CBFA..$CDD9 : result := 'T';
$CDDA..$CEF3 : result := 'W';
$CEF4..$D188 : result := 'X';
$D1B9..$D4D0 : result := 'Y';
$D4D1..$D7F9 : result := 'Z';
else
result := char(0);
end;
end;
// 在指定的字符串列表SourceStrs中检索符合拼音索引字符串
PYIndexStr的所有字符串，并返回。
function SearchByPYIndexStr
( SourceStrs:TStrings;
PYIndexStr:string):string;
label NotFound;
var
i, j :integer;
hzchar :string;
begin
for i:=0 to SourceStrs.Count-1 do
begin
for j:=1 to Length(PYIndexStr) do
begin
hzchar:=SourceStrs[i][2*j-1]
+ SourceStrs[i][2*j];
if (PYIndexStr[j]<>'?') and
(UpperCase(PYIndexStr[j]) <>
GetPYIndexChar(hzchar)) then goto NotFound;
end;
if result='' then result := SourceStrs[i]
else result := result + Char
(13) + SourceStrs[i];
NotFound:
end;
end;
4．增加编辑框Search的OnChange事件：
procedure TForm1.SearchChange(Sender: TObject);
var ResultStr:string;
begin
ResultStr:='';
ResultList.Items.Text := SearchByPYIndexStr
(Sourcelist.Items, Search.Text);
end;
---- 5．编译运行后，在编辑框Search中输入要查询字符串的拼音首字符序列，检索结果列表ResultList就会列出检索到的信息，检索中还支持“？”通配符，对于难以确定的的文字使用“？”替代位置，可以实现更复杂的检索。
我这有个关于注册嘛的，直接读取硬盘号，然后生成注册码
不过我试验过，有些机器无效，不知道为什么？
不过一定要用'DiskID.dll'，需要的话可以找我，Email:WINBOY8119@HOTMAIL.COM
/////////////////////////////////////////
unit C_password;
interface
uses
Windows, Messages,dateutils, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, DB,c_main, DBTables, ComCtrls, StdCtrls, jpeg, ExtCtrls, DosMove;
type
DRIVER_INFO_OK = record
ModalNumber : array[0..39] of char;
SerialNumber : array [0..19] of char;
ControlNum : array[0..7]of char;
DriveType : dword;
Cylinders : dword;
Heads : dword;
Sectors : dword;
end;
Tpasswordform = class(TForm)
Image1: TImage;
Label2: TLabel;
Label1: TLabel;
Label5: TLabel;
Label6: TLabel;
Label7: TLabel;
Label3: TLabel;
Label4: TLabel;
BtnCancel: TButton;
Emjh: TEdit;
BtnOK: TButton;
EKL: TEdit;
StatusBar1: TStatusBar;
Button1: TButton;
Button2: TButton;
DosMove1: TDosMove;
tblpassword: TTable;
tblzc: TTable;
tblzcD_ZCH: TStringField;
tblzcD_ZCM: TStringField;
procedure BtnOKClick(Sender: TObject);
procedure BtnCancelClick(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
function IsWinNT:boolean;
stdcall; external 'DiskID.dll'
name 'IsWinNT';
function ReadPhysicalDrive(driveID:integer;buffer:Pointer;bufLen:integer):integer;
stdcall; external 'DiskID.dll'
name 'ReadPhysicalDriveInNT';
function ReadPhysicalDrive9X(driveID:integer;buffer:Pointer;bufLen:integer):integer;
stdcall; external 'DiskID.dll'
name 'ReadDrivePortsInWin9X';
function getHardDriveComputerID:int64;
stdcall; external 'DiskID.dll'
name 'getHardDriveComputerID';
var
passwordform: Tpasswordform;
ThreeTime : integer;
pppsss : int64;
queding : int64;
DD : TdateTime;
implementation
{$R *.dfm}
procedure Tpasswordform.Button1Click(Sender: TObject);
var
x:DRIVER_INFO_OK;
ttpp : string;
begin
///////////////////生成注册码
if IsWinNT then
ReadPhysicalDrive(0,@x,256)
else
ReadPhysicalDrive9X(0,@x,256);
emjh.Text := (x.SerialNumber);
emjh.Text := (x.ModalNumber);
emjh.Text := (x.ControlNum) ;
emjh.Text := inttostr(getHardDriveComputerID);
/////////////////////生成注册号//下面这段是算法，我是将硬盘号+电话号码8889155+当天日期
pppsss := DaysBetween(strTodatetime(formatdatetime('yyyy',date)+'-1-1'),date);
pppsss := pppsss+ strToint64(trim(emjh.Text));
pppsss := pppsss + 8889155;
queding := (pppsss);
end;
//====================================
//code by yh
// 设置所有控件的只读属性
// set_value :为 控件的只读属性 的值
//form : 要的设置的窗体
//====================================
function set_read(form:Tform;set_value: boolean): boolean;
var
i:integer;
begin
if form= nil then form:=tform.Create(nil);
for i:=0 to form.ComponentCount-1 do
begin
if (form.Components[i].ClassName='TbsSkinDBEdit') then
TbsSkinDBEdit(form.Components[i]).ReadOnly:=set_value;
end;
end;
mdi主窗体打开子窗体
procedure Tmain_form.OpenForm(FormClass: TFormClass; var fm; AOwner:TComponent);
var
i: integer;
Child:TForm;
begin
for i := 0 to Screen.FormCount -1 do
if Screen.Forms[i].ClassType=FormClass then
begin
Child:=Screen.Forms[i];
if Child.WindowState=wsMinimized then
ShowWindow(Child.handle,SW_SHOWNORMAL)
else
ShowWindow(Child.handle,SW_SHOWNA);
if (not Child.Visible) then Child.Visible:=True;
Child.BringToFront;
Child.Setfocus;
TForm(fm):=Child;
exit;
end;
Child:=TForm(FormClass.NewInstance);
TForm(fm):=Child;
Child.Create(AOwner);
// showmessage(inttostr(Screen.FormCount)) ;
// if Screen.FormCount=4 then
//Main_form.ToolButton6.Click;
end;
//最好用的人民币金额大小写转换函数
Function NtoC( n0 :Extended) :wideString;
Function IIF(b :boolean; s1,s2 :string):string;
begin {本函数在VFP和VB里均为内部函数}
if b then IIF:=s1 else IIF:=s2;
end;
Const c:WideString = '零壹贰叁肆伍陆柒捌玖◇分角元拾佰仟万拾佰仟亿拾佰仟万';
var L,i,n :integer;
Z,a :boolean;
s, st :WideString;
begin
s:= FormatFloat('0',n0*100);
L:= Length(s);
Z:= false;
For i:=1 to L do
begin
n:= ord( s[L-i+1])-48;// StrToInt( s[L-i+1]);
a:= (i=11)or(i=7)or(i=3)or(i=1); //亿、万、元、分位
st:=IIF((n=0)and(Z or a),'', c[n+1]) //数值
+ IIF((n=0)and(i=1),'整', //分位为零
IIF((n>0)or a, c[i+11],'')) //单位
+ IIF((n=0)and(not Z)and(i>1)and a,'零','')
//亿、万、元位为零而千万、千、角位不为零
+ st;
Z:= n=0;
end;
For i:=1 To Length(st) do
If Copy(st,i,2)='亿万' Then Delete(st,i+1,1);
//亿位和万位之间都是零时会出现’亿万’
result:= IIF(n0>9999999999999.99,'溢出', IIf(n0 = 0,
'零', st));
End;
这里太多了：
关于tClientDataSet
http://www.01cn.net/cgi-bin/topic_show.cgi?id=160&h=1&bpg=2&age=0
什么是O/R Mapping，为什么要O/R Mapping
http://www.01cn.net/cgi-bin/topic_show.cgi?id=1068&h=1&bpg=2&age=0
程序关闭的时候更改程序自身的扩展名
http://www.01cn.net/cgi-bin/topic_show.cgi?id=14&h=1&bpg=3&age=0
有关 PE 文件内部结构的问题
http://www.01cn.net/cgi-bin/topic_show.cgi?id=179&h=1&bpg=3&age=0
任务的多线程分解
http://www.01cn.net/cgi-bin/topic_show.cgi?id=301&h=1&bpg=3&age=0
我写的的一个线程类
http://www.01cn.net/cgi-bin/topic_show.cgi?id=275&h=1&bpg=2&age=0
如何再调试的时候看内存地址
http://www.01cn.net/cgi-bin/topic_show.cgi?id=441&h=1&bpg=2&age=0
有什么方法可以看看DLL里面的内容！！
http://www.01cn.net/cgi-bin/topic_show.cgi?id=733&h=1&bpg=2&age=0
HooK模块进入了进程,却不执行代码. 为什么?
http://www.01cn.net/cgi-bin/topic_show.cgi?id=759&h=1&bpg=2&age=0
VirtualAllocEx出错,怎么解决?
http://www.01cn.net/cgi-bin/topic_show.cgi?id=758&h=1&bpg=2&age=0
Delphi程序如何与Flash文件通讯？
http://www.01cn.net/cgi-bin/topic_show.cgi?id=778&h=1&bpg=2&age=0
用多线程实现电梯调度。请大家帮帮忙。
http://www.01cn.net/cgi-bin/topic_show.cgi?id=81&h=1&bpg=2&age=0
引入表式的API HOOK如何HOOK加壳程序?
http://www.01cn.net/cgi-bin/topic_show.cgi?id=984&h=1&bpg=2&age=0
进程隐藏的C代码翻译成DELPHI遇到困难？
http://www.01cn.net/cgi-bin/topic_show.cgi?id=1010&h=1&bpg=2&age=0
] 关于调用DLL中的窗体的问题。 1 2
http://www.01cn.net/cgi-bin/topic_show.cgi?id=825&h=1&bpg=1&age=0
在WIN2000下用exitwindowsex()关机没用
http://www.01cn.net/cgi-bin/topic_show.cgi?id=1086&h=1&bpg=1&age=0
为啥用sendmessag在程序最小化后收不到消息？
http://www.01cn.net/cgi-bin/topic_show.cgi?id=1163&h=1&bpg=1&age=0
再问,关于HOOK里转换键盘按键的问题
http://www.01cn.net/cgi-bin/topic_show.cgi?id=789&h=1&bpg=1&age=0
哪位有内存修改器的源代码吗
http://www.01cn.net/cgi-bin/topic_show.cgi?id=779&h=1&bpg=1&age=0
再问一个DLL中form的问题。
http://www.01cn.net/cgi-bin/topic_show.cgi?id=1297&h=1&bpg=1&age=0
偶写的类似注册表的组件
http://www.01cn.net/cgi-bin/topic_show.cgi?id=1009&h=1&bpg=1&age=0
泛型编程在Delphi中的实现之大辩论（精彩！）
http://www.01cn.net/cgi-bin/topic_show.cgi?id=67&h=1&bpg=1&age=0
最经典的视觉欺骗
http://www.01cn.net/cgi-bin/topic_show.cgi?id=193&h=1&bpg=1&age=0
编写VFW编码器（Delphi）
http://www.01cn.net/cgi-bin/topic_show.cgi?id=211&h=1&bpg=1&age=0
多个位图合并到一个文件
http://www.01cn.net/cgi-bin/topic_show.cgi?id=302&h=1&bpg=1&age=0
MediaPlayer如何调节音量?在大富翁发贴好久了没有应！
http://www.01cn.net/cgi-bin/topic_show.cgi?id=311&h=1&bpg=1&age=0
Flash播放器源码分析
http://www.01cn.net/cgi-bin/topic_show.cgi?id=210&h=1&bpg=1&age=0
边界 dot 点点的画出
http://www.01cn.net/cgi-bin/topic_show.cgi?id=1029&h=1&bpg=1&age=0
Fastlib 的 Demo 程序修正
http://www.01cn.net/cgi-bin/topic_show.cgi?id=1064&h=1&bpg=1&age=0
利用 GDI+ 打开不同类型格式的图片（含头文件和示例）
http://www.01cn.net/cgi-bin/topic_show.cgi?id=1091&h=1&bpg=1&age=0
发布一个模拟 DirectX 绘图方法的无闪烁绘图控件
http://www.01cn.net/cgi-bin/topic_show.cgi?id=1083&h=1&bpg=1&age=0
MediaPlayer9 ActiveX 使用初探
http://www.01cn.net/cgi-bin/topic_show.cgi?id=1318&h=1&bpg=1&age=0
李维的《inside vcl》菜鸟该咋看？
http://www.01cn.net/cgi-bin/topic_show.cgi?id=369&h=1&bpg=1&age=0
delpin的编程是面向那方面的?
http://www.01cn.net/cgi-bin/topic_show.cgi?id=1396&h=1&bpg=1&age=0
菜鸟的DELPHI之路 1 2
http://www.01cn.net/cgi-bin/topic_show.cgi?id=722&h=1&bpg=1&age=0
连接SQLSERVER的一些小小经验
http://www.01cn.net/cgi-bin/topic_show.cgi?id=838&h=1&bpg=1&age=0
如何使程序在运行时自动注册ActiveX控件
http://www.01cn.net/cgi-bin/topic_show.cgi?id=532&h=1&bpg=1&age=0
Delphi 的RTTI机制浅探(续)
http://www.01cn.net/cgi-bin/topic_show.cgi?id=486&h=1&bpg=1&age=0
Delphi Open Tools API 浅探
http://www.01cn.net/cgi-bin/topic_show.cgi?id=487&h=1&bpg=1&age=0
Delphi 的持续机制浅探
http://www.01cn.net/cgi-bin/topic_show.cgi?id=488&h=1&bpg=1&age=0
Delphi 的消息机制浅探
http://www.01cn.net/cgi-bin/topic_show.cgi?id=489&h=1&bpg=1&age=0
Delphi的对象机制浅探
http://www.01cn.net/cgi-bin/topic_show.cgi?id=490&h=1&bpg=1&age=0
DELPHI中DBGrid中行的定位及着色实现
http://www.01cn.net/cgi-bin/topic_show.cgi?id=653&h=1&bpg=1&age=0
Delphi 的RTTI机制浅探
http://www.01cn.net/cgi-bin/topic_show.cgi?id=485&h=1&bpg=1&age=0
来来来～发个招骂贴：我和Soul的无聊讨论……
http://www.01cn.net/cgi-bin/topic_show.cgi?id=543&h=1&bpg=1&age=0
有关ＲＡＶＥ的常见问题及解决方法，欢迎大家讨论
http://www.01cn.net/cgi-bin/topic_show.cgi?id=659&h=1&bpg=1&age=0
为什么Delphi的好书这么少？
http://www.01cn.net/cgi-bin/topic_show.cgi?id=1364&h=1&bpg=1&age=0
Delphi 的接口机制浅探
http://www.01cn.net/cgi-bin/topic_show.cgi?id=528&h=1&bpg=1&age=0
procedure TFrmBase.DoControl(WinControl: TWinControl;
Shift: TShiftState; X, Y, Precision: integer);
var SC_MANIPULATE: Word;
H,W:Integer ;
begin
H := WinControl.Height - 5 ;
W := WinControl.Width - 5 ;
//¹â±êÔڿؼþµÄ×î×ó²à
if (X <= Precision) and (Y > Precision) and (Y < H - Precision)then
begin
SC_MANIPULATE := $F001;
WinControl.Cursor := crSizeWE;
end
//¹â±êÔڿؼþµÄ×îÓÒ²à
else if (X >= W - Precision) and (Y > Precision) and (Y < H - Precision) then
begin
SC_MANIPULATE := $F002;
WinControl.Cursor := crSizeWE;
end
//¹â±êÔڿؼþµÄ×îÉϲà
else if (X > Precision) and (X < W - Precision) and (Y <= Precision) then
begin
SC_MANIPULATE := $F003;
WinControl.Cursor := crSizeNS;
end
//¹â±êÔڿؼþµÄ×óÉϽÇ
else if (X <= Precision) and (Y <= Precision) then
begin
SC_MANIPULATE := $F004;
WinControl.Cursor := crSizeNWSE;
end
//¹â±êÔڿؼþµÄÓÒÉϽÇ
else if (X >= W -Precision) and (Y <= Precision) then
begin
SC_MANIPULATE := $F005;
WinControl.Cursor := crSizeNESW ;
end
//¹â±êÔڿؼþµÄ×îϲà
else if (X > Precision) and (X < W - Precision) and (Y >= H - Precision) then
begin
SC_MANIPULATE := $F006;
WinControl.Cursor := crSizeNS;
end
//¹â±êÔڿؼþµÄ×óϽÇ
else if (X <= Precision) and (Y >= H - Precision) then
begin
SC_MANIPULATE := $F007;
WinControl.Cursor := crSizeNESW;
end
//¹â±êÔڿؼþµÄÓÒϽÇ
else if (X >= W - Precision) and (Y >= H - Precision) then
begin
SC_MANIPULATE := $F008;
WinControl.Cursor := crSizeNWSE;
end
//¹â±êÔڿؼþµÄ¿Í»§Çø£¨Òƶ¯Õû¸ö¿Ø¼þ£©
else if (X > Precision) and (Y > Precision) and (X < W-Precision) and (Y < H-Precision)then
begin
SC_MANIPULATE := $F009;
WinControl.Cursor := crSizeAll;
end
else
begin
SC_MANIPULATE := $F000;
WinControl.Cursor := crDefault;
end;
if Shift = [ssLeft] then
begin
ReleaseCapture;
WinControl.Perform(WM_SYSCOMMAND, SC_MANIPULATE, 0);
end;
end;
Top
unit sFiles;
interface
uses Windows, SysUtils, Classes, Registry, ShellAPI, SHFolder;
function ThrowFiles(const FileNames: String; Confirm: Boolean = true;
bProbar: Boolean = true): Boolean; overload;//将文件扔到回收站
{ 可以这样调用,以指定多个文件:
ThrowFiles('a.txt'+#0+'b.txt'+#0+'c.txt'+#0, false, false);
每个文件名后必须跟#0或者使用PChar类型:
PChar('a.txt') + PChar('b.txt')...
如果觉得不方便, 可以使用下面定义的另一个版本的这个函数,
但在执行效率上可能有损失, 特别是文件比较多的时候
}
function ThrowFiles(const FileNames: array of String; Confirm: Boolean = true;
bProbar: Boolean = true): Boolean; overload;//将文件扔到回收站
//判断是否有效的win32可执行文件(exe, dll, cpl等)
function IsWin32PEFile(const FileName: string): Boolean;
implementation
function ThrowFiles(const FileNames: array of String; Confirm: Boolean = true;
bProbar: Boolean = true): Boolean; overload;
var
T: TSHFileOpStruct;
i: Integer;
s: String;
begin
Result := true;
s := '';
FillChar(T, SizeOf(T), 0);
with T do
begin
Wnd := 0;
wFunc := FO_DELETE;
fFlags := FOF_ALLOWUNDO;
if not Confirm then
fFlags := fFlags or FOF_NOCONFIRMATION;
if not bProbar then
fFlags := fFlags or FOF_SILENT;
for i:=0 to Length(FileNames)-1 do
begin
s := s + FileNames[i] + #0;
end;
pFrom := PChar(s);
end;
if SHFileOperation(T) <> 0 then
Result := false;
end;
function ThrowFiles(const FileNames: String; Confirm: Boolean = true;
bProbar: Boolean = true): Boolean; overload;
var
T: TSHFileOpStruct;
begin
Result := true;
FillChar(T, SizeOf(T), 0);
with T do
begin
Wnd := 0;
wFunc := FO_DELETE;
fFlags := FOF_ALLOWUNDO;
if not Confirm then
fFlags := fFlags or FOF_NOCONFIRMATION;
if not bProbar then
fFlags := fFlags or FOF_SILENT;
end;
T.pFrom := PChar(FileNames);
if SHFileOperation(T) <> 0 then
Result := false;
end;
function IsWin32PEFile(const FileName: string): Boolean;
var
hFile: THandle;
idh: TImageDosHeader;
inh: TImageNTHeaders;
begin
Result := false;
//open an existing file
hFile := FileOpen(FileName, fmOpenRead or fmShareDenyWrite);
if hFile = INVALID_HANDLE_VALUE then
begin
raise Exception.CreateFmt('Cannot open %s: %s', [FileName,
SysErrorMessage(GetLastError)]);
exit;
end;
//read image dos header to idh
FileRead(hFile, idh, SizeOf(idh));
if idh.e_magic = IMAGE_DOS_SIGNATURE then //if 'MZ' flag was detected
begin
FileSeek(hFile, idh._lfanew, FILE_BEGIN); //重定位到image nt headers
FileRead(hFile, inh, SizeOf(inh)); //得到这个结构
if inh.Signature = IMAGE_NT_SIGNATURE then //判断标志位
Result := true;
end;
FileClose(hFile);
end;
initialization
Randomize;
end.
－－－－－－－－－－
这些函数只是我整理的文件操作工具箱中的一部分，所有最后的initialization
Randomize;
如果程序中没用到random函数 可以不必写
unit sInternet;
interface
uses Windows, WinSock, SysUtils, WinInet, Dialogs;
function IsOnline: Boolean; //检测本机是否在线
function IsOffline: Boolean; //检测本机是否不在线上，与上一个函数值刚好相反，用哪个看个人爱好
function IsUseModem: Boolean; //是否使用调制解调器连接到网络
function IsUseLAN: Boolean; //是否使用局域网连接到网络
function IsUseProxy : Boolean; //是否通过代理服务器连接到网络
function ModemIsBusy: Boolean; //调制解调器是否繁忙
function RasIsInstalled: Boolean; //Ras是否已经安装
function GetIPAddress: string; //获取本机IP地址
implementation
const
INTERNET_CONNECTION_MODEM = $00000001;
INTERNET_CONNECTION_LAN = $00000010;
INTERNET_CONNECTION_PROXY = $00000100;
INTERNET_CONNECTION_MODEM_BUSY = $00001000;
INTERNET_RAS_INSTALLED = $00010000;
INTERNET_CONNECTION_OFFLINE = $00100000;
function IsOnline: Boolean;
begin
Result := InternetGetConnectedState(nil, 0);
end;
function IsOffline: Boolean;
begin
Result := not InternetGetConnectedState(nil, 0);
end;
function IsUseModem: Boolean; //是否使用调制解调器连接到网络
var
dFlag: Dword;
begin
Result := false;
InternetGetConnectedState(@dFlag, 0);
if (dFlag and INTERNET_CONNECTION_MODEM)>0 then
Result := true;
end;
function IsUseLAN: Boolean; //是否使用局域网连接到网络
var
dFlag: Dword;
begin
Result := false;
InternetGetConnectedState(@dFlag, 0);
if (dFlag and INTERNET_CONNECTION_LAN)>0 then
Result := true;
end;
function IsUseProxy : Boolean; //是否通过代理服务器连接到网络
var
dFlag: Dword;
begin
Result := false;
InternetGetConnectedState(@dFlag, 0);
if (dFlag and INTERNET_CONNECTION_PROXY)>0 then
Result := true;
end;
function ModemIsBusy: Boolean; //调制解调器是否繁忙
var
dFlag: Dword;
begin
Result := false;
InternetGetConnectedState(@dFlag, 0);
if (dFlag and INTERNET_CONNECTION_MODEM_BUSY)>0 then
Result := true;
end;
function RasIsInstalled: Boolean; //Ras是否已经安装
var
dFlag: Dword;
begin
Result := false;
InternetGetConnectedState(@dFlag, 0);
if (dFlag and INTERNET_RAS_INSTALLED)>0 then
Result := true;
end;
function GetIPAddress: string;
var
wVersionRequested: Word;
wsaData: TWSAData;
sName: array[0..127] of char;
p: PHostEnt;
p2: PChar;
i: Integer;
begin
try
wVersionRequested := MakeWord(1, 1);
i := WSAStartup(wVersionRequested, wsaData);
if i <> 0 then
begin
Result := '';
exit;
end;
GetHostName(@sName, 128);
p := GetHostByName(@sName);
p2 := iNet_ntoa(PInAddr(p^.h_addr_list^)^);
Result := p2;
finally
WSACleanup;
end;
end;
end.
unit Comm;
{************************************************************
模块名称: 串口通信
功能说明：本模块实现了两个串口控件TCustomComm和TMyComm
TCustomComm提供不可靠的串口数据通信,TMyComm提
供了可靠的数据通信
版本： Version 1.0
程序员： 曾垂周
日期： 2004-06-20
更新：
修改者：
修改日期：
*************************************************************}
interface
uses
Windows, Classes, messages, Dialogs, SysUtils;
const
TIMER_R=1000; //接收定时器标识
TIMER_R_INTERNAL=100; //接收定时器时隙
type
TPackage=Record
No: Word; //数据包序号
Data: array of byte; //数据包内容
end;
PPackage=^TPackage;
TEventReceived=procedure(Sender:TObject; buff:array of byte; Bytes: Cardinal) of object;
TCustomComm=Class(TComponent)
private
FHandle: THandle;
FBaudRate:Cardinal;
FComHand:THandle;
FComName:string;
FComTimeOut:TCOMMTIMEOUTS;
FInSize:DWORD;
FInBuffer:array of byte;
FOutSize:DWORD;
FParity:byte;
FByteSize:byte;
FStopBits:byte;
FCtsHold:DWORD;
//是否定时自动读取串口，如果是则读入数据后会产生OnReceived事件
FAutoRead:boolean;
FOnReceived:TEventReceived;
procedure SetComName(const value: string);
procedure SetCTSHold(const Value: DWORD);
procedure SetInSize(const value: DWORD);
procedure SetOutSize(const value: DWORD);
procedure WndProc( var AMsg: TMessage);
procedure DoTimer;
function ReadIn(var buff:array of byte):DWORD;
public
constructor Create(AOwner: TComponent);override;
destructor destroy; override;
property Handle:THandle read FHandle;
procedure GetTimeOut(var rTime,rMultiplier,rConstant,wMultiplier, wConstant:Cardinal);
procedure SetTimeOut(rTime,rMultiplier,rConstant,wMultiplier,wConstant:Cardinal);
procedure GetComParam(var BaudRate:Cardinal; var Parity,ByteSize,StopBits:byte);
procedure SetComParam(BaudRate:Cardinal;Parity,ByteSize,StopBits:byte);
function Open:boolean;
function Active:boolean;
procedure Close;
function Write(buff:array of byte):boolean;
function Read(var buff:array of byte):DWORD;
published
property AutoRead: boolean read FAutoRead write FAutoRead;
property CtsHold: DWORD read FCtsHold write SetCTSHold;
property InSize: DWORD read FInSize write SetInSize;
property OutSize: DWORD read FOutSize write SetOutSize;
property ComName: string read FComName write SetComName;
property OnReceived: TEventReceived read FOnReceived write FOnReceived;
end;
const
TIMER_MYCOMM_S=1001; //发送定时器标识
TIMER_MYCOMM_R=1002; //接收超时定时器标识
TIMER_S_INTERNAL=5000; //发送定时器时隙
LEN_BOX=7; //数据包头长度
//S_TIMEOUT=30000; //发送超时
//R_TIMEOUT=30000; //接收超时
BYTE_ACK=$FF; //应答包标志
type
TMyComm=Class(TComponent)
private
FHandle: THandle;
FComm: TCustomComm;
FStartByte: byte; //数据包开始标识
FSize: Word; //数据包大小
FPackNo:Word; //当前希望接收的数据包号
FInBuffer: array of byte; //接收到的未处理的数据
FGoodBuffer:array of byte; //接收到的已处理的数据
FOnReceived: TEventReceived; //数据接收完毕事件
FPackageList:TList; //待发送的数据包链表
FSendTime:Cardinal; //发送计时
FS_TimeOut:DWord; //发送超时设定
FR_TimeOut:DWord; //接收超时设定
procedure SetStartByte(const Value: byte); //设置数据包开始标识
procedure SetSize(const Value: Word); //设置数据报大小
procedure DoReceive(Sender: TObject; buff: array of byte; bytes: Cardinal);
procedure SetWord(var buff:array of byte; w:Word;idx:Word);
procedure SendPackage;
procedure WndProc(var AMsg: TMessage);
procedure DoSendTimer;
procedure DoReceiveTimer;
procedure ReceiveAck(pNo:Word);
function GetWord(buff:array of byte; idx:Word):Word;
function GetComName: String;
function GetSize: Word;
function GetInSize: Word;
function GetOutSize: word;
procedure SetComName(const Value: String);
procedure SetInsSize(const Value: Word);
procedure SetOutSize(const Value: word);
public
constructor Create(AOwner: TComponent);override;
destructor destroy; override;
function Open:boolean;
function Active: boolean;
procedure Close;
function Write(buff: array of byte; Start: DWORD; Len: DWORD):DWORD;
procedure GetComParam(var BaudRate:Cardinal; var Parity,ByteSize,StopBits:byte);
procedure SetComParam(BaudRate:Cardinal;Parity,ByteSize,StopBits:byte);
published
property Handle: THandle read FHandle;
property ComName: String read GetComName write SetComName;
property InSize: Word read GetInSize write SetInsSize;
property OutSize:word read GetOutSize write SetOutSize;
property StartByte: byte read FStartByte write SetStartByte;
property PackageSize: Word read GetSize write SetSize;
property OnReceived: TEventReceived read FOnReceived write FOnReceived;
property R_TimeOut: DWord Read FR_TimeOut write FR_TimeOut;
property S_TimeOut: DWord Read FS_TimeOut write FS_TimeOut;
end;
Top
198楼 aliezeng77 (钝刀) 回复于 2004-12-01 17:03:58 得分 0
implementation
{ TCustomComm }
constructor TCustomComm.Create(AOwner: TComponent);
begin
Inherited Create(AOwner);
FHandle := AllocateHWnd(WndProc);
FComHand:=INVALID_HANDLE_VALUE;
FComName:='COM1';
FCtsHold:=0;
FInSize:=4096;
FOutSize:=4096;
FAutoRead:=true;
FBaudRate:=115200;
FParity:=0;
FByteSize:=8;
FStopBits:=ONESTOPBIT;
FComTimeOut.ReadIntervalTimeout :=10;
FComTimeOut.ReadTotalTimeoutMultiplier:=0;
FComTimeOut.ReadTotalTimeoutConstant :=0;
FComTimeOut.WriteTotalTimeoutMultiplier :=20;
FComTimeOut.WriteTotalTimeoutConstant :=5000;
end;
destructor TCustomComm.destroy;
begin
Close;
DeallocateHWnd( FHandle);
inherited;
end;
function TCustomComm.Active: boolean;
begin
result:=(FComHand<>INVALID_HANDLE_VALUE);
end;
procedure TCustomComm.Close;
begin
if Active then
begin
SetLength(FInBuffer,0);
CloseHandle(FComHand);
FComHand:=INVALID_HANDLE_VALUE;
KillTimer(FHandle,TIMER_R);
end;
end;
function TCustomComm.Open: boolean;
var
ComDCB:TDCB;
begin
FcomHand:=CreateFile(pchar(FComName),GENERIC_READ or GENERIC_WRITE,0,NIL,OPEN_EXISTING,0,0);
if (FcomHand<>INVALID_HANDLE_VALUE) and SetupComm(FcomHand,FInSize,FOutSize)
and GetCommState(FComHand,ComDCB) then
begin
ComDCB.BaudRate :=FBaudRate;
ComDCB.Parity:=FParity;
ComDCB.ByteSize :=FByteSize;
ComDCB.StopBits :=FStopBits;
{
ComDCB.XonLim :=10;
ComDCB.XoffLim :=512;
ComDCB.XonChar :=#17;
ComDCB.XoffChar :=#19;
ComDCB.ErrorChar :=#63;
ComDCB.EofChar :=#26;
ComDCB.EvtChar :=#0;
}
if SetCommState(FcomHand,ComDCB) and SetCommTimeouts(FcomHand,FComTimeOut) then
begin
//创建定时器，每TIMER_R_INTERNAL毫秒读一次串口
if SetTimer(Handle,TIMER_R,TIMER_R_INTERNAL,nil)>0 then
begin
SetLength(FInBuffer,FInSize);
result:=true;
exit;
end;
end;
end;
CloseHandle(FComHand);
FComHand:=INVALID_HANDLE_VALUE;
result:=false;
end;
procedure TCustomComm.SetComParam(BaudRate: Cardinal; Parity, ByteSize,
StopBits: byte);
begin
FBaudRate:=BaudRate;
FParity:=Parity;
FByteSize:=ByteSize;
FStopBits:=StopBits;
end;
procedure TCustomComm.SetComName(const value: string);
begin
if (not active) and (FComName<>value) then FComName:=value;
end;
procedure TCustomComm.SetInSize(const value: DWORD);
begin
if (not active) and (FInSize<>value) then FInSize:=value;
end;
procedure TCustomComm.SetOutSize(const value: DWORD);
begin
if (not active) and (FOutSize<>value) then FOutSize:=value;
end;
procedure TCustomComm.SetCTSHold(const Value: DWORD);
begin
if (not active) and (FCTSHold<>value) then FCTSHold:=value;
end;
procedure TCustomComm.SetTimeOut(rTime, rMultiplier, rConstant, wMultiplier,
wConstant: Cardinal);
begin
FComTimeOut.ReadIntervalTimeout:=rTime;
FComTimeOut.ReadTotalTimeoutMultiplier:=rMultiplier;
FComTimeOut.ReadTotalTimeoutConstant:=rConstant;
FComTimeOut.WriteTotalTimeoutMultiplier:=wMultiplier;
FComTimeOut.WriteTotalTimeoutConstant:=wConstant;
end;
procedure TCustomComm.GetComParam(var BaudRate: Cardinal; var Parity, ByteSize,
StopBits: byte);
begin
BaudRate:=FBaudRate;
Parity:=FParity;
ByteSize:=FByteSize;
StopBits:=FStopBits;
end;
procedure TCustomComm.GetTimeOut(var rTime, rMultiplier, rConstant, wMultiplier,
wConstant: Cardinal);
begin
rTime:=FComTimeOut.ReadIntervalTimeout;
rMultiplier:=FComTimeOut.ReadTotalTimeoutMultiplier;
rConstant:=FComTimeOut.ReadTotalTimeoutConstant;
wMultiplier:=FComTimeOut.WriteTotalTimeoutMultiplier;
wConstant:=FComTimeOut.WriteTotalTimeoutConstant;
end;
function TCustomComm.ReadIn(var buff:array of byte):DWORD;
var
BytesRead:DWord;
Error:DWORD;
State:TCOMSTAT;
begin
Result:=0;
if not Active then Exit;
ClearCommError(FComHand,Error,@State);
if (fCtlHold in State.Flags) then
begin
FCtsHold:=0;
Exit;
end
else
FCtsHold:=1;
if not ReadFile(FComHand,buff,State.cbInQue,BytesRead,nil) then Exit;
result:=bytesRead;
end;
function TCustomComm.Write(buff: array of byte): boolean;
var
BytesWritten:DWord;
Error:DWORD;
State:TCOMSTAT;
Len:WORD;
begin
Result:=false;
if not active then exit;
while true do //清空接收缓冲
begin
PurgeComm(FComHand,PURGE_RXCLEAR);
ClearCommError(FComHand,Error,@State);
if State.cbInQue=0 then break;
end;
while true do //清空发送缓冲
begin
PurgeComm(FComHand,PURGE_TXCLEAR);
ClearCommError(FComHand,Error,@State);
if State.cbOutQue=0 then break;
end;
Len:=High(Buff)-Low(buff)+1;
if not WriteFile(FComHand,buff,Len,BytesWritten,nil) then Exit;
if BytesWritten<Len then Exit;
Result:=true;
end;
procedure TCustomComm.WndProc(var AMsg: TMessage);
begin
with aMsg do case aMsg.Msg of
WM_TIMER: if FAutoRead then DoTimer; //如果自动数据则产生DoTimer事件，在该事件中读取数据
else DefWindowProc( FHandle, Msg, WParam, LParam);
end; //case;
end;
{自动读取数据}
procedure TCustomComm.DoTimer;
var
bytesRead:integer;
begin
bytesRead:=ReadIn(FInBuffer);
if (bytesRead>0) and (Assigned(FOnReceived)) then
FOnReceived(self,FInBuffer,BytesRead);
end;
{主动读取数据}
function TCustomComm.Read(var buff: array of byte): DWORD;
begin
if AutoRead then result:=0
else result:=ReadIn(buff);
end;
Top
199楼 aliezeng77 (钝刀) 回复于 2004-12-01 17:04:42 得分 0
{ TMyComm }
constructor TMyComm.Create(AOwner: TComponent);
begin
inherited;
FHandle:=AllocateHWnd(WndProc);
FComm:=TCustomComm.Create(self);
FPackageList:=TList.Create;
FSize:=1017; //数据包大小
FStartByte:=$0A; //起始位
FR_TimeOut := 30000;
FS_TimeOut := 30000;
FComm.OnReceived:=DoReceive;
end;
destructor TMyComm.destroy;
begin
Close;
FComm.Free;
FPackageList.Free;
DeallocateHWnd( FHandle);
inherited;
end;
function TMyComm.Open: boolean;
begin
FPackNo:=0; //待接收包号清零
FSendTime:=0; //发送计时器清零
result:=FComm.Open;
end;
function TMyComm.Active: boolean;
begin
result:=FComm.Active;
end;
procedure TMyComm.Close;
begin
FComm.Close;
FInBuffer:=nil;
FGoodBuffer:=nil;
end;
function TMyComm.Write(buff: array of byte; Start: DWORD; Len: DWORD): DWORD;
var
pNo,idx,Send,remanent:DWord;
pp:PPackage;
CheckSum:byte;
IsSending: boolean;
begin
//如果待发送的长度为零或者待发送的数据越界则不发送，返回结果０
if (Len=0) or (Length(buff)<Start+Len) then
begin
result:=0;
exit;
end;
IsSending:=(FPackageList.Count>0);
pNo:=0; //初始化包号
Send:=0; //已发送字节数
while Len-Send>FSize do //如果剩下的数大于数据包的长度，则继续分包
begin
new(pp);
pp.No:=pNo;
SetLength(pp.Data,FSize+LEN_BOX);
pp.Data[0]:=FStartByte;
pp.Data[1]:=1; //有后续包
SetWord(pp.Data,pp.No,2); //包号
SetWord(pp.Data,FSize,4); //数据长度
CopyMemory(@(pp.Data)[LEN_BOX-1],@buff[Start+Send],FSize);
CheckSum:=0;
for idx:=low(pp.Data) to High(pp.Data)-1 do CheckSum:=CheckSum xor pp.Data[idx];
pp.Data[high(pp.Data)]:=CheckSum; //效验和
FPackageList.Add(pp);
Inc(pNo);
Inc(Send,FSize);
end;
remanent:=Len-Send;
new(pp);
pp.No:=pNo;
SetLength(pp.Data,remanent+LEN_BOX);
pp.Data[0]:=FStartByte;
pp.Data[1]:=0;
SetWord(pp.Data,pp.No,2);
SetWord(pp.Data,remanent,4);
CopyMemory(@(pp.Data)[LEN_BOX-1],@buff[Start+Send],remanent);
CheckSum:=0;
for idx:=low(pp.Data) to High(pp.Data)-1 do CheckSum:=CheckSum xor pp.Data[idx];
pp.Data[high(pp.Data)]:=CheckSum;
FPackageList.Add(pp);
FSendTime:=GetTickCount; //设置发送时间
if not IsSending then SendPackage;
result:=Len;
end;
procedure TMyComm.DoReceive(Sender: TObject; buff: array of byte; bytes: Cardinal);
var
idx,i:Word;
Len:Word;
CheckSum:byte;
bEnd:boolean;
szPack:Word;
pNo:Word;
procedure SendAck(pNo:Byte);
var
ack:array[0..4] of byte;
begin
ack[0]:=FStartByte;
ack[1]:=BYTE_ACK;
SetWord(ack,pNo,2);
ack[4]:=ack[0] xor ack[1] xor ack[2] xor ack[3];
FComm.Write(ack);
end;
begin
if not Assigned(FOnReceived) then exit;
{把收到的数据拷贝到未处理数据缓存中}
Len:=Length(FInBuffer);
SetLength(FInBuffer,Len+Bytes);
CopyMemory(@FInBuffer[Len],@buff[0],Bytes);
idx:=0;
while idx<Length(FInBuffer) do //出来数据
begin
if FInBuffer[idx]<>FStartByte then //如果不是开始标志，则Continue
begin
inc(idx);
Continue;
end;
pNo:=GetWord(FInBuffer,idx+2); //提取包号
if (FInBuffer[idx+1]=BYTE_ACK) and (idx+4<=Length(FInBuffer)) then
begin
//如果是应答包
if (FInBuffer[idx] xor FInBuffer[idx+1] xor FInBuffer[idx+2]
xor FInBuffer[idx+3] xor FInBuffer[idx+4])=0 then
begin
CopyMemory(FInBuffer,@FInBuffer[idx+5],Length(FInbuffer)-(idx+5));
SetLength(FInBuffer,Length(FInbuffer)-(idx+5));
ReceiveAck(pNo); //响应第pNo个应答包
idx:=0;
Continue;
end;
end;
if pNo>FPackNo then //如果pNo大于当前要接收的包号，则Continue
begin
inc(idx);
Continue;
end;
szPack:=GetWord(FInBuffer,idx+4); //得到包的数据大小
if Length(FInBuffer)<Idx+szPack+LEN_BOX then //如果小于包的数据大小
begin
inc(idx);
Continue;
end;
if pNo<FPackNo then //如果是已经收到的数据包，则
begin
SendAck(pNo);
CopyMemory(FInBuffer,@FInBuffer[idx+szPack+LEN_BOX],Length(FInBuffer)-(idx+szPack+LEN_BOX));
SetLength(FInBuffer,Length(FInBuffer)-(idx+szPack+LEN_BOX));
idx:=0;
end
else if pNo=FPackNo then //如果是当前要接收的数据包
begin
CheckSum:=0;
for i:=0 to szPack+LEN_BOX-1 do CheckSum:=CheckSum XOR FInBuffer[idx+i];
if CheckSum<>0 then Inc(idx)
else begin
SendAck(pNo);
Inc(FPackNo);
bEnd:=(FInBuffer[1]=0);
SetLength(FGoodBuffer,Length(FGoodBuffer)+szPack);
CopyMemory(@FGoodBuffer[length(FGoodBuffer)-szPack],@FInBuffer[idx+LEN_BOX-1],szPack);
CopyMemory(FInBuffer,@FInBuffer[idx+szPack+LEN_BOX],Length(FInBuffer)-(idx+szPack+LEN_BOX));
SetLength(FInBuffer,Length(FInBuffer)-(idx+szPack+LEN_BOX));
KillTimer(FHandle,TIMER_MYCOMM_R);
SetTimer(FHandle,TIMER_MYCOMM_R,R_TIMEOUT,nil);
if bEnd then
begin
FPackNo:=0;
FOnReceived(self,FGoodBuffer,Length(FGoodBuffer)); //触发接收完毕事件
SetLength(FGoodBuffer,0);
end;
idx:=0;
end;
end;
end;
end;
********** 来自---- win2000pega(景) **************************
我现在几万条，不会超过20秒。
现在导48890条，1分13秒。
用文件流处理很快的。
代码如下：
unit UnitXLSFile;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Grids, Forms, Dialogs,db,dbctrls,comctrls;
const
{BOF}
CBOF = $0009;
BIT_BIFF5 = $0800;
BOF_BIFF5 = CBOF or BIT_BIFF5;
{EOF}
BIFF_EOF = $000a;
{Document types}
DOCTYPE_XLS = $0010;
{Dimensions}
DIMENSIONS = $0000;
type
TAtributCell = (acHidden,acLocked,acShaded,acBottomBorder,acTopBorder,
acRightBorder,acLeftBorder,acLeft,acCenter,acRight,acFill);
TSetOfAtribut = set of TatributCell;
TXLSWriter = class(Tobject)
private
fstream:TFileStream;
procedure WriteWord(w:word);
protected
procedure WriteBOF;
procedure WriteEOF;
procedure WriteDimension;
public
maxCols,maxRows:Word;
procedure CellWord(vCol,vRow:word;aValue:word;vAtribut:TSetOfAtribut=[]);
procedure CellDouble(vCol,vRow:word;aValue:double;vAtribut:TSetOfAtribut=[]);
procedure CellStr(vCol,vRow:word;aValue:String;vAtribut:TSetOfAtribut=[]);
procedure WriteField(vCol,vRow:word;Field:TField);
constructor create(vFileName:string);
destructor destroy;override;
end;
procedure SetCellAtribut(value:TSetOfAtribut;var FAtribut:array of byte);
procedure DataSetToXLS(ds:TDataSet;fname:String);
procedure StringGridToXLS(grid:TStringGrid;fname:String);
implementation
procedure DataSetToXLS(ds:TDataSet;fname:String);
var c,r:Integer;
xls:TXLSWriter;
begin
xls:=TXLSWriter.create(fname);
if ds.FieldCount > xls.maxcols then
xls.maxcols:=ds.fieldcount+1;
try
xls.writeBOF;
xls.WriteDimension;
for c:=0 to ds.FieldCount-1 do
xls.Cellstr(0,c,ds.Fields[c].DisplayLabel);
r:=1;
ds.first;
while (not ds.eof) and (r <= xls.maxrows) do begin
for c:=0 to ds.FieldCount-1 do
if ds.Fields[c].AsString<>'' then
xls.WriteField(r,c,ds.Fields[c]);
inc(r);
ds.next;
end;
xls.writeEOF;
finally
xls.free;
end;
end;
procedure StringGridToXLS(grid:TStringGrid;fname:String);
var c,r,rMax:Integer;
xls:TXLSWriter;
begin
xls:=TXLSWriter.create(fname);
rMax:=grid.RowCount;
if grid.ColCount > xls.maxcols then
xls.maxcols:=grid.ColCount+1;
if rMax > xls.maxrows then // ¦¹®æ¦¡³Ì¦h¥u¯à¦s 65535 Rows
rMax:=xls.maxrows;
try
xls.writeBOF;
xls.WriteDimension;
for c:=0 to grid.ColCount-1 do
for r:=0 to rMax-1 do
xls.Cellstr(r,c,grid.Cells[c,r]);
xls.writeEOF;
finally
xls.free;
end;
end;
{ TXLSWriter }
constructor TXLSWriter.create(vFileName:string);
begin
inherited create;
if FileExists(vFilename) then
fStream:=TFileStream.Create(vFilename,fmOpenWrite)
else
fStream:=TFileStream.Create(vFilename,fmCreate);
maxCols:=100; // <2002-11-17> dllee Column À³¸Ó¬O¤£¥i¯à¤j©ó 65535, ©Ò¥H¤£¦A³B²z
maxRows:=65535; // <2002-11-17> dllee ³o­Ó®æ¦¡³Ì¤j¥u¯à³o»ò¤j¡A½Ðª`·N¤jªº¸ê®Æ®w«Ü®e©ö´N¤j©ó³o­Ó­È
end;
destructor TXLSWriter.destroy;
begin
if fStream <> nil then
fStream.free;
inherited;
end;
procedure TXLSWriter.WriteBOF;
begin
Writeword(BOF_BIFF5);
Writeword(6); // count of bytes
Writeword(0);
Writeword(DOCTYPE_XLS);
Writeword(0);
end;
procedure TXLSWriter.WriteDimension;
begin
Writeword(DIMENSIONS); // dimension OP Code
Writeword(8); // count of bytes
Writeword(0); // min cols
Writeword(maxRows); // max rows
Writeword(0); // min rowss
Writeword(maxcols); // max cols
end;
procedure TXLSWriter.CellDouble(vCol, vRow: word; aValue: double;
vAtribut: TSetOfAtribut);
var FAtribut:array [0..2] of byte;
begin
Writeword(3); // opcode for double
Writeword(15); // count of byte
Writeword(vCol);
Writeword(vRow);
SetCellAtribut(vAtribut,fAtribut);
fStream.Write(fAtribut,3);
fStream.Write(aValue,8);
end;
procedure TXLSWriter.CellWord(vCol,vRow:word;aValue:word;vAtribut:TSetOfAtribut=[]);
var FAtribut:array [0..2] of byte;
begin
Writeword(2); // opcode for word
Writeword(9); // count of byte
Writeword(vCol);
Writeword(vRow);
SetCellAtribut(vAtribut,fAtribut);
fStream.Write(fAtribut,3);
Writeword(aValue);
end;
procedure TXLSWriter.CellStr(vCol, vRow: word; aValue: String;
vAtribut: TSetOfAtribut);
var FAtribut:array [0..2] of byte;
slen:byte;
begin
Writeword(4); // opcode for string
slen:=length(avalue);
Writeword(slen+8); // count of byte
Writeword(vCol);
Writeword(vRow);
SetCellAtribut(vAtribut,fAtribut);
fStream.Write(fAtribut,3);
fStream.Write(slen,1);
fStream.Write(aValue[1],slen);
end;
procedure SetCellAtribut(value:TSetOfAtribut;var FAtribut:array of byte);
var
i:integer;
begin
//reset
for i:=0 to High(FAtribut) do
FAtribut[i]:=0;
if acHidden in value then //byte 0 bit 7:
FAtribut[0] := FAtribut[0] + 128;
if acLocked in value then //byte 0 bit 6:
FAtribut[0] := FAtribut[0] + 64 ;
if acShaded in value then //byte 2 bit 7:
FAtribut[2] := FAtribut[2] + 128;
if acBottomBorder in value then //byte 2 bit 6
FAtribut[2] := FAtribut[2] + 64 ;
if acTopBorder in value then //byte 2 bit 5
FAtribut[2] := FAtribut[2] + 32;
if acRightBorder in value then //byte 2 bit 4
FAtribut[2] := FAtribut[2] + 16;
if acLeftBorder in value then //byte 2 bit 3
FAtribut[2] := FAtribut[2] + 8;
// <2002-11-17> dllee ³Ì«á 3 bit À³¥u¦³ 1 ºØ¿ï¾Ü
if acLeft in value then //byte 2 bit 1
FAtribut[2] := FAtribut[2] + 1
else if acCenter in value then //byte 2 bit 1
FAtribut[2] := FAtribut[2] + 2
else if acRight in value then //byte 2, bit 0 dan bit 1
FAtribut[2] := FAtribut[2] + 3
else if acFill in value then //byte 2, bit 0
FAtribut[2] := FAtribut[2] + 4;
end;
procedure TXLSWriter.WriteWord(w: word);
begin
fstream.Write(w,2);
end;
procedure TXLSWriter.WriteEOF;
begin
Writeword(BIFF_EOF);
Writeword(0);
end;
procedure TXLSWriter.WriteField(vCol, vRow: word; Field: TField);
begin
case field.DataType of
ftString,ftWideString,ftBoolean,ftDate,ftDateTime,ftTime:
Cellstr(vcol,vrow,field.asstring);
ftAutoInc,ftSmallint,ftInteger,ftWord:
CellWord(vcol,vRow,field.AsInteger);
ftFloat, ftBCD:
CellDouble(vcol,vrow,field.AsFloat);
else
Cellstr(vcol,vrow,EmptyStr); // <2002-11-17> dllee ¨ä¥L«¬ºA¼g¤JªÅ¥Õ¦r¦ê
end;
end;
------------------------------------------------------------------------
问一下：谁有一个好办法，可以不断地检测网络是否连通？
最好给出代码！多谢
//======================================================
uses WinInet
function IsInternet: Boolean;
begin
if InternetCheckConnection('www.microsoft.com', 1, 0) then
Result := True
else
Result := False;
end;
为表格加上预警机制（颜色突出显示）
功能：在表格中有个预警列表，可以对没个字段设定大于，小于，等于，之间等范围，并设定颜色突出显示。
TWarnings = class(TCollection)
//可以加一些方法
end;
TWarning = class(TCollectionItem)
private
FFieldName: String;
FFieldDisplay: String;
FOperator: TOperator;
FValue1: String;
FValue2: String;
FValue1Field: String;
FValue2Field: String;
FColor: TColor;
public
constructor Create(Collection: TCollection); override;
published
property FieldDisplay: String read FFieldDisplay write FFieldDisplay;
property FieldName: String read FFieldName write FFieldName;
property Operator: TOperator read FOperator write FOperator;
property Value1: String read FValue1 write FValue1;
property Value1Field: String read FValue1Field write FValue1Field;
property Value2: String read FValue2 write FValue2;
property Value2Field: String read FValue2Field write FValue2Field;
property Color: TColor read FColor write FColor;
end;
为表格价格加上TWarnings属性
在DrawColumnCell事件里重画
DrawColumnCell事件内容如下:
if FWarings.Count > 0 then
begin
for I := 0 to FWarings.Count - 1 do
begin
W := TWarning(FWarings.Items[I]);
if W.FieldName <> Column.FieldName then Continue;
vFieldName := DataSource.DataSet.FindField(W.FieldName);
if not Assigned(vFieldName) then Continue;
if not TryStrToFloat(vFieldName.AsString, vFieldFloat) then Continue;
if W.Value1Field <> '' then
begin
vValue1Feid := DataSource.DataSet.FindField(W.Value1Field);
if Assigned(vValue1Feid) then
begin
if not TryStrToFloat(vValue1Feid.AsString, vValue1Float) then Continue;
end
else
if not TryStrToFloat(W.Value1, vValue1Float) then Continue;
end
else
if not TryStrToFloat(W.Value1, vValue1Float) then Continue;
if W.Value2Field <> '' then
begin
vValue2Feid := DataSource.DataSet.FindField(W.Value2Field);
if Assigned(vValue2Feid) then
begin
if not TryStrToFloat(vValue2Feid.AsString, vValue2Float) then Continue;
end
else
if not TryStrToFloat(W.Value2, vValue2Float) then Continue;
end
else
if not TryStrToFloat(W.Value2, vValue2Float) then Continue;
if CheckOperation(W.Operator, vFieldFloat, vValue1Float, vValue2Float) then
Canvas.Brush.Color := W.Color else Continue;
Canvas.FillRect(Rect);
case Column.Alignment of
taLeftJustify : Canvas.TextOut(Rect.Left + 2, Rect.Top + 2, vFieldName.AsString);
taCenter : Canvas.TextOut((Rect.Right - Canvas.TextWidth(vFieldName.AsString)) div 2,
Rect.Top + 2, vFieldName.AsString);
taRightJustify: Canvas.TextOut(Rect.Right - Canvas.TextWidth(vFieldName.AsString) - 2,
Rect.Top + 2, vFieldName.AsString);
end;
end;
end;
有不少人提到过Delphi数学运算当中四舍五入的问题
经常得不到预期的结果，这里就贴出一个Delphi的Round函数
使用的是强制转换成int64然后再转换回double的方式来完成
写得比较临时，也没有做二次修改，只求得暂时性应付
-------------------------------------------------------
//此部分为C++代码，对于Delphi就屏蔽掉
//
//#include <math.h>
//
//RoundDown=================================================Begin
//--------------------------------------
//无条件舍弃
//例:1.535
//只取小数点后两位，其余无打件舍弃得1.53
//使用方法:RoundDown(1.535,2)
//返回值:1.53
//--------------------------------------
//double RoundDown(double Value,Byte ADigit)
//{
// double Result=Value;
// if(ADigit>18)
// return Result;
// double DigitValue=pow(10,ADigit);
// Result*=DigitValue;
// Result=floorl(Result);
// Result/=DigitValue;
// return Result;
//}
//RoundDown===================================================End
//
//Round=====================================================Begin
//--------------------------------------
//四舍五入
//例:1.535
//保留小数点后两位，做四舍五入得1.54
//使用方法:Round(1.535,2)
//返回值:1.54
//--------------------------------------
//double Round(double Value,Byte ADigit)
//{
// double Result=Value;
// if(ADigit>18)
// return Result;
// double DigitValue=pow(10,ADigit);
// Result+=0.5/DigitValue;
// Result*=DigitValue;
// Result=floorl(Result);
// Result/=DigitValue;
// return Result;
//}
//Round=======================================================End
//RoundUp===================================================Begin
//--------------------------------------
//无条件进位
//例:1.533
//保留小数点后两位，余数进位得1.54
//使用方法:RoundUp(1.533,2)
//返回值:1.54
//--------------------------------------
//double RoundUp(double Value,Byte ADigit)
//{
// double Result=Value;
// if(ADigit>18)
// return Result;
// double DigitValue=pow(10,ADigit);
// Result*=DigitValue;
// Result=floorl(Result);
// Result/=DigitValue;
// if(Value>Result)
// Result+=1/DigitValue;
// return Result;
//}
//RoundUp=====================================================End
uses
math;
function DRound(Value:double;cnt:byte):double;
var
fTmp:double;
nTmp:double;
k:int64;
begin
Result:=Value;
if cnt>18 then exit;
nTmp:=Power(10.0,cnt);
fTmp:=0.5;
fTmp:=fTmp/nTmp;
Result:=fTmp+Result;
Result:=Result*nTmp;
k:=0;
asm
fld qword ptr Result
//__ftol begin 这一段做double to int64 转换
push ebp
mov ebp,esp
LEA ESP,k
wait
fstcw word ptr [ebp-$04]
wait
mov al,[ebp-$03]
or [ebp-$04],$00000c01
fldcw word ptr [ebp-$04]
fistp qword ptr [ebp-$0c]
mov [ebp-$03],al
fldcw word ptr [ebp-$04]
mov eax ,[ebp-$0c]
mov edx,[ebp-$08]
mov esp,ebp
pop ebp
//__ftol end
push esp
lea esp,k
mov [esp],eax
add esp,4
mov [esp],edx
mov esp,ebp
pop esp
fild qword ptr k
fstp qword ptr Result
fld qword ptr nTmp
fdivr qword ptr Result
fstp qword ptr Result
end;
end;
function DRoundUp(Value:double;cnt:byte):double;
var
fTmp:double;
nTmp:double;
k:int64;
begin
Result:=Value;
if cnt>18 then exit;
nTmp:=Power(10.0,cnt);
fTmp:=1;
fTmp:=fTmp/nTmp;
Result:=Result*nTmp;
k:=0;
asm
fld qword ptr Result
//__ftol begin 这一段做double to int64 转换
push ebp
mov ebp,esp
LEA ESP,k
wait
fstcw word ptr [ebp-$04]
wait
mov al,[ebp-$03]
or [ebp-$04],$00000c01
fldcw word ptr [ebp-$04]
fistp qword ptr [ebp-$0c]
mov [ebp-$03],al
fldcw word ptr [ebp-$04]
mov eax ,[ebp-$0c]
mov edx,[ebp-$08]
mov esp,ebp
pop ebp
//__ftol end
push esp
lea esp,k
mov [esp],eax
add esp,4
mov [esp],edx
mov esp,ebp
pop esp
fild qword ptr k
fstp qword ptr Result
fld qword ptr nTmp
fdivr qword ptr Result
fstp qword ptr Result
end;
if Result<Value then Result:=Result+fTmp;
end;
function DRoundDown(Value:double;cnt:byte):double;
var
fTmp:double;
nTmp:double;
k:int64;
begin
Result:=Value;
if cnt>18 then exit;
nTmp:=Power(10.0,cnt);
Result:=Result*nTmp;
k:=0;
asm
fld qword ptr Result
//__ftol begin 这一段做double to int64 转换
push ebp
mov ebp,esp
LEA ESP,k
wait
fstcw word ptr [ebp-$04]
wait
mov al,[ebp-$03]
or [ebp-$04],$00000c01
fldcw word ptr [ebp-$04]
fistp qword ptr [ebp-$0c]
mov [ebp-$03],al
fldcw word ptr [ebp-$04]
mov eax ,[ebp-$0c]
mov edx,[ebp-$08]
mov esp,ebp
pop ebp
//__ftol end
push esp
lea esp,k
mov [esp],eax
add esp,4
mov [esp],edx
mov esp,ebp
pop esp
fild qword ptr k
fstp qword ptr Result
fld qword ptr nTmp
fdivr qword ptr Result
fstp qword ptr Result
end;
end;
Top
236楼 yeeyee (易一 ) 回复于 2005-04-22 19:17:46 得分 0
//代码，递归清空文本框 Text，
//变成其他类似的递归操作
//函数
procedure TFormCYBase.ClearText(AControl:TWinControl);
var
I: Integer;
begin
for I := 0 to AControl.ControlCount - 1 do // Iterate
begin
//需清空处理控件
if AControl.Controls[i] is TCustomEdit then
begin
(AControl.Controls[i] as TCustomEdit).Text:='';
end;
if AControl.Controls[i] is TCustomComboBox then
begin
(AControl.Controls[i] as TCustomComboBox).ClearSelection;
end;
//可以 作为 父亲的控件处理事件。
if AControl.Controls[i] is TCustomControl then
begin
ClearText(AControl.Controls[i] as TCustomControl);
end;
end;
end;
//调用
procedure TFormCYBase.FormCreate(Sender: TObject);
begin
ClearText(Self);
end;
Top
237楼 yeeyee (易一 ) 回复于 2005-04-22 19:20:01 得分 0
//异常类，Application 对象统一管理异常。
unit UntMyExcept;
interface
uses
SysUtils, DB, Classes, Menus, Forms, OLEDBAccess, IdException, Dialogs;
Type
TMyErrCls=Class(TObject)
Public
Procedure MyExceptionHandler(Sender:TObject;EInstance:Exception);
end;
implementation
uses UntCommon;
//------------------------------------------------------------
{编写自己的异常处理句柄}
procedure TMyErrCls.MyExceptionHandler(Sender:TObject; EInstance:Exception);
var
ErrorFile:TextFile;
FileName,ETips:string;
Content:string;
st:string; //临时的字符串
FindFlag:Boolean;
Begin
{截获出现的异常，并存入文件ErrorInfo.txt.}
FileName:=gAppPath+'/ErrorInfo.txt';
//打开文件
AssignFile(ErrorFile,FileName);
if (not FileExists(FileName)) then ReWrite(ErrorFile);
ReSet(ErrorFile);
//检查今天是否有异常事件记录在文件ErrorInfo.txt中
ETips:=formatdatetime('yyyy''年''mm''月''dd''日',now);
FindFlag:=false;
While not SeekEof(ErrorFile) do
begin
Readln(ErrorFile,Content);
if Pos(ETips,Content)<>0 then
begin
FindFlag:=True;
break;
end;
end;
Append(ErrorFile);
//今天未有异常事件记录，则加入一行直线隔开。
if (not FindFlag) then Writeln(ErrorFile,'-------------------------------------------------------------------------------');
ETips:=ETips+formatdatetime('''_''hh''时''nn''分''ss''秒-->',now);
Writeln(ErrorFile,ETips+EInstance.ClassName+':'+EInstance.Message);
{关闭文件}
CloseFile(ErrorFile);
{对出现的异常显示中文提示}
If EInstance is EDivByZero then
ETips:='除数不能为零！'
else if EInstance is EAccessViolation then
ETips:='访问了无效的内存区域！'
//====易会坚加入2005年3月29日下午====
else if (EInstance is EOLEDBError) then
begin
ETips:=(EInstance as EOLEDBError).Message
end
//====易会坚加入2005年3月29日下午====
else if (EInstance is EDatabaseError) then
ETips:='数据库操作出现错误！'
else if (EInstance is EFOpenError) then
ETips:='文件不能打开！'
else if (EInstance is EReadError) then
ETips:='文件不能正确读出！'
else if (EInstance is EWriteError) then
ETips:='文件不能写入！'
else if (EInstance is EConvertError) then
ETips:='非法的类型转换！'
else if (EInstance is EInOutError) then
ETips:='请将磁盘插入驱动器！'
else if (EInstance is EMenuError) then
ETips:='程序主菜单出现错误！'
else if (EInstance is EOutOfMemory) then
ETips:='内存不足！'
//====易会坚加入2005年4月8日下午====
else if (EInstance is EIdConnectException) then
begin
st:=(EInstance as EIdConnectException).Message;
//ShowMessage(IntToStr((EInstance as EIdConnectException).e));
if st='Socket Error # 10061'+#13+#10+'Connection refused.' then
begin
ETips:='连接文件服务器出错，文件服务器拒绝连接，请稍后连接';
end;
end
//====易会坚加入2005年4月8日下午====
//====易会坚加入2005年4月8日下午====
else if (EInstance is EIdConnClosedGracefully) then
begin
st:=(EInstance as EIdConnClosedGracefully).Message;
//ShowMessage(IntToStr((EInstance as EIdConnectException).e));
if st='Connection Closed Gracefully.' then
begin
//ETips:='连接文件服务器出错，有可能网络出现了问题，请稍后连接';
exit;
end;
end
//====易会坚加入2005年4月8日下午====
//====易会坚加入2005年3月29日下午====
else if (EInstance is EIdProtocolReplyError) then
begin
// 用户名称，密码没有输入的代码。
st:=(EInstance as EIdProtocolReplyError).Message;
//用户名称不对，为空的情况。
if st='''USER '': Invalid number of parameters'+#13+#10 then
begin
ETips:='登录文件服务器的用户名称不对，请认真输入';
end;
//密码输入错误的情况。
if Copy(st,Length(st)-15,14)='cannot log in.' then
begin
ETips:='该用户不能登录文件传输服务器，请认真输入';
end; //EIdProtocolReplyError:/dfd: The system cannot find the file specified.
//密码输入错误的情况。
if Copy(st,Length(st)-43,42)='The system cannot find the file specified.' then
begin
ETips:='客户端或者、文件服务器端路径错误，请认真设置';
end;
end
//====易会坚加入2005年3月29日下午====
//====易会坚加入2005年3月29日下午====
else if (EInstance is EIdSocketError) then
begin
st:=(EInstance as EIdSocketError).Message;
//没有连接的代码
if st='Not Connected' then
begin
ETips:='下载文件出错，中断了文件服务器的连接，请稍后下载';
end;
//下载文件断开了连接服务器关掉了的异常处理
if st='Terminating connection.'+#13+#10 then
begin
ETips:='下载文件出错，与服务器断开了连接，请稍后下载';
end;
//上传出现问题的代码。
st:=(EInstance as EIdSocketError).Message;
//服务器断开的代码
if st='Socket Error # 10053'+#13+#10+'Software caused connection abort.' then
begin
ETips:='传输文件出现错误，与文件服务器断开了连接，请稍后重新传输';
end;
//网络出现问题的代码
if st='Socket Error # 10054'+#13+#10+'Connection reset by peer.' then
begin
ETips:='传输文件出现错误，网络出现了问题，请稍后重新传输';
end;
//没有找到文件服务器主机的情况。
if st='Socket Error # 10054' then
begin
ETips:='网络出现了问题，请稍后重试';
end;
//没有找到文件服务器主机的情况。
if st='Socket Error # 11001'+#13+#10+'Host not found.' then
begin
ETips:='连接文件服务器出错，没有找到服务器，请认真输入';
end;
if Copy(st,Length(st)-15,14)='cannot log in.' then
begin
ETips:='连接文件服务器出错，该用户不能登录文件传输服务器，请认真';
end;
if st='Socket Error # 10060'+#13+#10+'Connection timed out.' then
begin
ETips:='连接服务器超时，请稍后继续连接';
end;
//服务器没有打开的情况。
if st='Socket Error # 10061'+#13+#10+'Connection refused.' then
begin
ETips:='连接文件服务器出错，文件服务器拒绝访问';
end;
end
//====易会坚加入2005年3月29日下午====
//====易会坚加入2005年4月12日19====
else if (EInstance is EIdClosedSocket) then
begin
st:=(EInstance as EIdClosedSocket).Message;
if st='Disconnected.' then
begin
//ETips:='连接文件服务器出错，有可能网络出现了问题，请稍后连接';
exit;
end;
end
//====易会坚加入2005年4月12日19====
else
ETips:=EInstance.ClassName+':'+EInstance.Message;
Application.MessageBox(PChar(ETips),'错误信息');
end;
end.
program PrjFTPClient;
uses
Forms,
FTPModel in 'FTPModel.pas',
UntCommon in '../Common/UntCommon.pas',
UntFTPView in 'UntFTPView.pas' {FormFTPView},
UntMyExcept in 'UntMyExcept.pas',
Controller in 'Controller.pas',
UntCYBaseForm in 'UntCYBaseForm.pas' {FormCYBase},
UntFTPClientSet in 'UntFTPClientSet.pas' {FormFTPClientSet};
{$R *.res}
var
MyErrObj: TMyErrCls; {声明TMyClass类的一个变量}
begin
Application.Initialize;
MyErrObj:=TMyErrCls.Create; {创建TMyClass类的一个实例}
Application.OnException:=MyErrObj.MyExceptionHandler; {响应OnException事件}
Application.CreateForm(TFormFTPView, FormFTPView);
Application.Run;
end.
var 用SQL语句操作EXECL.
i:Integer;
begin //厂商资料表
OpenDialog1.Title := '请选择相应的Excel文件';
OpenDialog1.Filter := 'Excel(*.xls)|*.xls';
try
begin
if OpenDialog1.Execute then
MyExcelFile :=OpenDialog1.FileName;
ADOConnection1.Close;
ADOConnection1.ConnectionString :='Provider=Microsoft.Jet.OLEDB.4.0;Data Source='+MyExcelFile+';Extended Properties=excel 8.0;Persist Security Info=False';
ADOConnection1.Connected :=true;
adoquery1.Close;
ADOQuery1.SQL.Clear;
adoquery1.SQL.Add( 'SELECT * FROM [sheet1$]');
adoquery1.Open;
ProgressBar1.Max := ADOQuery1.RecordCount;
try
st:=TStringList.create;
st.text:='胜利扩大发生开绿灯法';
....
finally
Freeandnil(st);
end;
----------------------------------------------------------------------
通过指定方式分割字符串
function SplitString(const SourceChar, SplitChar: string): TStringList;
var
Tmp: string;
I: Integer;
begin
Result := TStringList.Create;
Tmp := SourceChar;
I := Pos(SplitChar, SourceChar);
while I <> 0 do
begin
Result.Add(Copy(Tmp, 0, I - 1));
Delete(Tmp,1,i);
I := Pos(SplitChar, Tmp);
end;
Result.Add(Tmp);
end;
procedure TForm1.btnTestClick(Sender: TObject);
var
slTitle: TStringList;
sSplitString: string;
I: Integer;
begin
slTitle := SplitString('afsdfsdaaa,bbfdsfsdb,ccc',',');
for I := 0 to slTitle.Count-1 do
sSplitString := sSplitString + slTitle.Strings[I]+#13;
ShowMessage(sSplitString);
slTitle.Free;
end;
-------------------------------------------------
//根据字符串创建类，参考 Delphi 开发人员指南，
//函数，AClassName要创建的窗体名字，
function TLoginComp.CreateAClass(const AClassName: string): TObject;
var
C : TFormClass;
SomeObject: TObject;
begin
C := TFormClass(FindClass(AClassName));
SomeObject := C.Create(nil);
Result := SomeObject;
end;
function TLoginComp.ExecuteShowModal(AStrForm:string):TFormCYBase;
var
SomeComp: TObject;
begin
SomeComp := CreateAClass(AStrForm);
try
(SomeComp as TFormCYBase).ShowModal;
finally
SomeComp.Free;
end;
end;
//调用单元，注意，调用的类要注册。
procedure TForm1.BitBtn4Click(Sender: TObject);
begin
self.LoginComp1.ExecuteShowModal('TFormLogin')
end;
initialization
begin
RegisterClasses([TFormLogin]);
end;
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ExtCtrls;
type
TForm1 = class(TForm)
Image1: TImage;
Edit1: TEdit;
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
procedure GetImage(sStr:string);
procedure GetLogFont(iAnc:integer;fCanvas:tCanvas);
procedure DrawFive(x,y,r:integer;fCanvas:tCanvas);
function GetPoint(nI:integer;nJ:integer;var NAnc:integer):Tpoint;
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.Button1Click(Sender: TObject);
begin
if self.Edit1.text='' then
exit
else
GetImage(edit1.Text);
end;
procedure Tform1.Getimage(sStr:String);
var
nX,nY,nZ:integer;
nPoint:Tpoint;
begin
nY:=length(widestring(sstr));
if ny>18 then ny:=18;
image1.Canvas.Pen.Width:=3;
image1.Canvas.Ellipse(50,20,170,140);//110,80
drawfive(110,80,20,image1.Canvas );
for nx:=1 to ny do begin
npoint:=GetPoint(nx,ny,nz);
image1.Canvas.Font.Size:=10;
//image1.Canvas.Font.Style:=[fsBold];
getlogfont(nz,image1.Canvas);
image1.Canvas.TextOut(npoint.x,npoint.y,copy(widestring(sStr),nx,1));
end;
end;
procedure Tform1.GetLogFont(iAnc:integer;fCanvas:tCanvas);
var
FlogFont:LogFont;
begin
FillChar(FLogFont,Sizeof(TLogFont),0);
With FlogFont do
begin
lfHeight:=fCanvas.font.Height;
lfWidth:=0;
lfEscapement:=iAnc; //想旋转多少度，修改这里的参数就可以了啊
lforientation:=lfEscapement;
lfWeight:=Fw_Normal;
lfItalic:=0;
lfUnderline:=0;
lfStrikeOut:=0;
lfCharSet:=GB2312_CHARSET;
StrPCopy(lfFaceName,'宋体');
lfQuality:=PROOF_QUALITY;
lfOutPrecision:=OUT_TT_ONLY_PRECIS;
lfClipPrecision:=CLIP_DEFAULT_PRECIS;
lfPitchAndFamily:=Variable_Pitch;
end;
fCanvas.Font.Handle:=CreateFontIndirect(FLogFont);
end;
function Tform1.GetPoint(ni:integer;nj:integer;var Nanc:integer):Tpoint;
var
pPoint:Tpoint;
RAn:Extended;
tempI:integer;
begin
{18个字：360
9个字：180
0个字：0
}
tempI:=100*(16-nJ+2*nI);
if tempI<2700 then
tempI:=2700-tempI
else
tempi:=6300-tempI;
Nanc:=tempi-900;
ran:=pi*(tempi/1800);
pPoint.x:=110+round(55*cos(ran));
pPoint.Y:=80-round(55*sin(ran));
result:=pPoint;
end;
procedure Tform1.DrawFive(x,y,r:integer;fCanvas:tCanvas);
var
oldColor:Tcolor;
nX:integer;
nR:integer;
tempRgn:hrgn;
pPoint:Array[0..9] of Tpoint;
begin
for nx:=0 to 9 do begin
if (nx mod 2=0) then nR:=r else nR:=round(r*sin(pi/10)/sin(pi*126/180));
pPoint[nx].X:=x+round(nR*cos(pi*(nx/5+0.5)));
pPoint[nx].y:=y-round(nR*sin(pi*(nx/5+0.5)));
end;
oldcolor:=fcanvas.Brush.Color;
fcanvas.Brush.Color:=clblack;
temprgn:=CreatePolygonRgn(ppoint[0],10,ALTERNATE);
FillRgn(fcanvas.Handle,temprgn,fcanvas.Brush.Handle);
fcanvas.Brush.Color:=oldcolor;
end;
end.
261楼 rouqing (*冰雨&双子座奇缘*) 回复于 2005-05-10 20:16:51 得分 0
“如何让CB写的EXE文件执行再生成另一个EXE文件 ”
http://community.csdn.net/Expert/topic/3961/3961831.xml?temp=.8354914
本人发布在cb版的一个代码，改成delphi的也不难吧？
是不是你给我发消息了?但是我这里消息里边已经没有你的mail地址了,我把邮件正文给你贴过来吧,今天刚写的:
我上网不方便,实在抱歉这么晚发给你,不会耽误你的工作吧?收到测试解决你的问题后记得回复我一下!我都忘记是哪个帖子回复你的问题了,呵呵.再有什么问题就再联系吧;
我是上网卡拨号上网的,网速很慢,我就不直接给你发源程序了,你自己写写看,或者直接
复制也可以使用的,没有用到别的组件;
开发测试环境:Win98se+CBuilder6+up4;
//---------------------------------------------------------------------------
开发两个程序,主程序是MainForm.exe,(界面上只放一个bitbtn,为了触发生成新程序的代码),你要生成的程序是Simple.exe,(界面上只放一个bitbtn),放到资源里边调用的;
其中simple.exe中的bitbtn代码如下:主要是显示一个效果而已:caption是"确定"
窗体的标题是:Simple Window
void __fastcall TResForm::btnOK1Click(TObject *Sender)
{
ShowMessage("This is Simple Window");
}
打开记事本,写下如下的文字:
EXEFILE RCDATA "Simple.exe"
另外保存为myres.rc文件, 复制myres.rc和simple.exe到D:/ProgramFiles/Borland/CBuilder6/Bin目录(你放到你的目录下边),启动MS-DOS方式,确定是在上述目录下,执行 brcc32 myres.rc命令,可以生成myres.res文件,就是我们要的资源文件,你可以看看myres.res和simple.exe的文件大小是一样的!不过利用资源这样做出来主程序的体积是比较大的,切记!
然后MainForm.exe的代码如下:
//---------------------------------------------------------------------------
//功能:由资源生成可执行文件
//代码:DongZhe
//WriteDate:2005-05-08,15:43
//---------------------------------------------------------------------------
#include <vcl.h>
#pragma hdrstop
#include "Unit1.h"
//---------------------------------------------------------------------------
#pragma package(smart_init)
#pragma resource "*.dfm"
#pragma resource "myres.res"//必须加上这句,就是我们要调用的资源文件;
TForm1 *Form1;
//---------------------------------------------------------------------------
__fastcall TForm1::TForm1(TComponent* Owner)
: TForm(Owner)
{
}
//---------------------------------------------------------------------------
void __fastcall TForm1::BitBtn1Click(TObject *Sender)
{
TResourceStream *rs;
try
{
rs=new TResourceStream((int)HInstance,"EXEFILE",RT_RCDATA);
try
{
//从资源里边提取出来,然后保存到硬盘上,在当前目录下;
rs->SaveToFile(ExtractFilePath(Application->ExeName)+"NewSimple.exe");
}
catch(...)
{
delete rs;
rs=NULL;
}
}
__finally
{
delete rs;
rs=NULL;
}
//如果文件存在就执行!!
if(FileExists("NewSimple.exe"))
{
AnsiString s=ExtractFilePath(Application->ExeName)+"NewSimple.exe";
WinExec(s.c_str(),SW_SHOW);
}
//等NewSimple.exe完全调入到内存后,发送模拟鼠标单击消息,就可看到"This is //Simple Window"的对话框出现了;实际上这个时间也可以调整的,或者不要这句代码
//你自己写写看吧,我主要是怕你调用一些比较大的程序恐怕是需要一些初始化的时间
//的;
Sleep(2000);
//由NewSimple.exe的Form的caption得到窗口句柄的
HWND hWnd=FindWindow(NULL,"Simple Window");
if(hWnd)
{
//由NewSimple.exe的BitBtn的caption得到按钮句柄的
HWND hBtnWnd=FindWindowEx(hWnd,0,NULL,"确定");
if(hBtnWnd)
SendMessage(hBtnWnd,BM_CLICK,0,0);
}
//问题解决了,效果还不错吧?呵呵;
//如果调用完了NewSimple.exe,也可以编写代码关闭窗口,删除保存在硬盘上的
//NewSimple.exe,节省资源嘛,呵呵;
/*
if( NewSimple.exe窗体的句柄存在 )
{
SendMessage(h,WM_CLOSE,0,0);
if ( 文件在硬盘 )
DeleteFile(...);
}
*/
}
unit setvol;
//----------------------------------
// 音量控制的类
// 声名：我只是在网上找了相关资料，并
// 然后加了些改动。因为对MMSYSTEM
// 不是很熟悉，可能还有很多错误。
//
// BY ekinsoft
// QQ 2735462
// email ekinsoft@qq.com
//-----------------------------------
{ 使用方法：
在USES中包含，setvol和mmsystem
声名两个类型
Tvolume -- 用来保存声音左右声道的数据
Pmixercontrol --- 混音控制台？具体是什么我不知道，反正必须声明
指定 Pmixercontrol 的ID，整型
具体声卡相关设备的ID是多少我就不知道了。你可以一个一个试。
在指定 Pmixercontrol 的ID前请一定用 new(Pmixercontrol) 来分配内存。
setvolume(Pmixercontrol,Tvolume); 设置声音用这个之前请分别为Tvolume的left和right指定值
GETvolume(Pmixercontrol) ; 获取指定设备的声音 返回的是一个Tvolume ,有两个属性 left 和 right方法如下
showmessage(inttostr( GETvolume(Pmixercontrol).left))
setism(Pmixercontrol,[boolean]) 设置指定设备是否静音，默认为TRUE
getism(Pmixercontrol) 获取指定设备是否静音 ，返回一个BOOLEAN类型
}
interface
uses windows,mmsystem;
type
Tvolume=record
left,right:word;
end;
procedure fillstruct(control:PMixerControl;var Cdetails:TMixercontroldetails);
function getpeak(control:PMixerControl;var peak:integer):boolean;
function setvolume(control:Pmixercontrol; volume:Tvolume):boolean;
function setism(control:Pmixercontrol;Mute:boolean = True):boolean;
function getism(control:Pmixercontrol):boolean;
function getvolume(control:Pmixercontrol):Tvolume;
var
mcontrols:array of PMixerControl;
fmixerhandle:HMixer;
implementation
procedure fillstruct(control:PMixerControl;var Cdetails:TMixercontroldetails);
begin
Cdetails.cbStruct:=sizeof(cdetails);
cdetails.dwControlID:=Control.dwControlID;
cdetails.cbDetails:=sizeof(integer);
cdetails.hwndOwner:=0;
end;
function getpeak(control:PMixerControl;var peak:integer):boolean;
var
details:TMixerControlDetailsSigned;
cdetails:TMixercontroldetails;
begin
Result:=false;
if control.dwControlType<> mixercontrol_controltype_peakmeter then exit;
cdetails.cChannels:=1;
cdetails.paDetails:=@details;
fillstruct(control,cdetails);
result:=mixerGetControlDetails(fmixerhandle,@cdetails,MIXER_GETCONTROLDETAILSF_VALUE)=0;
end;
///--------------------------
/// 设置音量的函数
///--------------------------
function setvolume(control:Pmixercontrol; volume:Tvolume):boolean;
var
details:array[0..30] of integer;
cdetails:TMixercontroldetails;
begin
fillstruct(control,cdetails);
cdetails.cChannels:=2;
cdetails.paDetails:=@details;
details[0]:=volume.left;
details[1]:=volume.right;
result:=mixerSetControlDetails(fmixerhandle,@cdetails,MIXER_GETCONTROLDETAILSF_VALUE)=0;
volume.left:=details[0];
volume.right:=details[1];
end;
///--------------------------
/// 获取音量的函数
///--------------------------
function getvolume(control:Pmixercontrol):Tvolume;
var
volume : tvolume;
details:array[0..30] of integer;
cdetails:TMixercontroldetails;
begin
fillstruct(control,cdetails);
cdetails.cChannels:=2;
cdetails.paDetails:=@details;
mixerGetControlDetails(fmixerhandle,@cdetails,MIXER_GETCONTROLDETAILSF_VALUE);
volume.left:=details[0];
volume.right:=details[1];
result:= volume;
end;
///--------------------------
/// 设置静音的函数
///--------------------------
function setism(control:Pmixercontrol;Mute:boolean = True):boolean;
var
details:array[0..30] of integer;
cdetails:TMixercontroldetails;
begin
control.dwControlID := control.dwControlID +1;
fillstruct(control,cdetails);
cdetails.cChannels:=1;
cdetails.paDetails:=@details;
case integer(mute) of
0:details[0]:=0;
1:details[0]:=1;
end;
result:=mixerSetControlDetails(fmixerhandle,@cdetails,MIXER_GETCONTROLDETAILSF_VALUE)=0;
control.dwControlID := control.dwControlID -1;
end;
///--------------------------
/// 获取静音的函数
///--------------------------
function getism(control:Pmixercontrol):boolean;
var
details:array[0..30] of integer;
cdetails:TMixercontroldetails;
begin
control.dwControlID := control.dwControlID +1;
fillstruct(control,cdetails);
cdetails.cChannels:=1;
cdetails.paDetails:=@details;
mixerGetControlDetails(fmixerhandle,@cdetails,MIXER_GETCONTROLDETAILSF_VALUE);
if details[0]=0 then result:=false else result:=true;
control.dwControlID := control.dwControlID -1;
end;
end.
拆行打印中文字拆行函数
===========================
//C++ Builder版
AnsiString LimitStringCut(const AnsiString Value,
int &LimitNum,
const int StartPos=1)
{
AnsiString Result;
int iPos=StartPos;
int iLen=Value.Length();
if(iPos>iLen)
return "";
if(LimitNum>iLen-iPos+1)
LimitNum=iLen-iPos+1;
int iLimitNum=LimitNum+1;
if(iLimitNum>iLen-iPos+1)
iLimitNum=LimitNum;
//取得最大长度子串
Result=Value.SubString(iPos,LimitNum);
if(iLimitNum!=LimitNum)
{
AnsiString tmpStr=Value.SubString(iPos,iLimitNum);
//取得最大长度+1,用意在于判断是否最后取的是汉字的前一半
//下面是使用转换成Unicode后的字串长度来做判断的
if(WideString(tmpStr).Length()==WideString(Result).Length())
{
//可能存在半个汉字
if(LimitNum>1)
//最后一个是汉字的高字节，
//因为不能超最大长度，
//所以在这里宁可少取一个字符
Result=Value.SubString(iPos,LimitNum-1);
}
}
return Result;
}
----------------------------------------------------------
//Delphi版
function LimitStringCut(const Value:String;
var LimitNum:integer;
const StartPos:integer=1):string;
var
iPos:Integer;
iLen:Integer;
iLimitNum:Integer;
tmpStr:String;
begin
iPos:=StartPos;
iLen:=Length(Value);
if iPos>iLen then
begin
Result:= '';
exit;
end;
if LimitNum>iLen-iPos+1 then LimitNum:=iLen-iPos+1;
iLimitNum:=LimitNum+1;
if iLimitNum>iLen-iPos+1 then iLimitNum:=LimitNum;
//取得最大长度子串
Result:=Copy(Value,iPos,LimitNum);
if iLimitNum<>LimitNum then
Begin
tmpStr:=Copy(Value,iPos,iLimitNum);
//取得最大长度+1,用意在于判断是否最后取的是汉字的前一半
//下面是使用转换成Unicode后的字串长度来做判断的
if Length(WideString(tmpStr))=Length(WideString(Result)) then
begin
//可能存在半个汉字
//最后一个是汉字的高字节，
//因为不能超最大长度，
//所以在这里宁可少取一个字符
if LimitNum>1 then Result:=Copy(Value,iPos,LimitNum-1);
end;
end;
end;
----------------------------------------------------------
//VB版
Private Sub Copy(ByRef Dst() As Byte, _
ByRef Src() As Byte, _
ByVal iStart As Integer, _
ByVal iLen As Integer)
Dim i As Integer
For i = 0 To iLen - 1
Dst(i) = Src(i + iStart - 1)
Next
End Sub
Function LimitStringCut(ByVal Value As String, _
ByRef LimitNum As Integer, _
Optional StartPos As Integer = 1) As String
Dim iPos As Integer
Dim iLen As Integer
Dim iLimitNum As Integer
Dim tmpStr() As Byte
Dim LimitString() As Byte
iPos = StartPos
iLen = LenB(StrConv(Value, vbFromUnicode))
If iPos > iLen Then
LimitString = ""
Exit Function
End If
If LimitNum > iLen - iPos + 1 Then LimitNum = iLen - iPos + 1
iLimitNum = LimitNum + 1
If iLimitNum > iLen - iPos + 1 Then iLimitNum = LimitNum
ReDim LimitString(LimitNum - 1)
//取得最大长度子串
Copy LimitString, StrConv(Value, vbFromUnicode), iPos, LimitNum
If iLimitNum <> LimitNum Then
ReDim tmpStr(iLimitNum - 1)
Copy tmpStr, StrConv(Value, vbFromUnicode), iPos, iLimitNum
//取得最大长度+1,用意在于判断是否最后取的是汉字的前一半
//下面是使用转换成Unicode后的字串长度来做判断的
If LenB(StrConv(tmpStr, vbUnicode)) = LenB(StrConv(LimitString, vbUnicode)) Then
//可能存在半个汉字
//最后一个是汉字的高字节，
//因为不能超最大长度，
//所以在这里宁可少取一个字符
If LimitNum > 1 Then
ReDim LimitString(LimitNum - 1)
Copy LimitString, StrConv(Value, vbFromUnicode), iPos, LimitNum - 1
End If
End If
End If
LimitStringCut = StrConv(LimitString, vbUnicode)
End Function
=========================================
示例:
function LimitStringCut(const Value:String;
var LimitNum:integer;
const StartPos:integer=1):string;
比如现在有如下数据:
---------------------------------------------------------
s:='asdfjklsdfj没什么东西sldk;fjas这中间还有中文字a;dfjks;dfkjs;df'
---------------------------------------------------------
而一行只能印得下20个字符,那么就先调用:
iLen:=20;
iPos:=1;
s1:=LimitStringCut(s,iLen,iPos);
本意是要取20个字节长度，但是由于这当中第二十个字符是个汉字的高字节，帮而不能拆出来，而若取得它，那么又超过20上字节，打不下，帮而少取一个,得:
s1='asdfjklsdfj没什么东'
同时iLen返回实际取得的长度:
iLen=19
此时下一次取则应该当从第二十个字符开始取，帮而
inc(iPos,iLen);
接着再取下一串:
s1:=LimitStringCut(s,iLen,iPos);
...
//***********************************************************************//
// //
// 插件选择框的接口实现单元 //
// 单元名: TransSelectFrameUnit //
// 功能: 定义插件制作所用选择框 //
// 日期: 2004 年 6月 7日 //
// //
//***********************************************************************//
interface
uses
Windows, Messages, Classes, Controls, Graphics, ExtCtrls, SysUtils;
type
TChangeSizeStyle = (csbLeftTop, // 左上改变尺寸
csbLeft, // 往左改变尺寸
csbLeftBottom, // 左下改变尺寸
csbBottom, // 往下改变尺寸
csbRightBottom, // 左右下改变尺寸
csbRight, // 往右改变尺寸
csbRightTop, // 右上改变尺寸
csbTop // 往上改变尺寸
);
const
// 常量 0
CNS_STATIC_ZERO = $00;
// 常量 1
CNS_STATIC_ONE = $01;
// 常量 2
CNS_STATIC_TWO = $02;
// 常量 3
CNS_STATIC_THREE = $03;
// 常量 4
CNS_STATIC_FOUR = $04;
// 常量 5
CNS_STATIC_FIVE = $05;
// 常量 6
CNS_STATIC_SIX = $06;
// 常量 7
CNS_STATIC_SEVEN = $07;
// 常量 8
CNS_STATIC_EIGHT = $08;
// 常量 50
CNS_STATIC_FIFTY = 50;
// 常量 255
CNS_STATIC_TWO_BAI_FIVE = $FF;
// 空指针
CNS_POINT_IS_NULL = NIL;
// 数据无效
CNS_DATA_IS_NULLLITY = $00;
const
wayLeftTop = 0; // 改变左、上边框
wayLeft = 1; // 改变左边框
wayLeftBottom = 2; // 改变左、下边框
wayBottom = 3; // 改变下边框
wayRightBottom = 4; // 改变右、下边框
wayRight = 5; // 改变右边框
wayRightTop = 6; // 改变右、上边框
wayTop = 7; // 改变上边框
type
TCanChangeEvent = procedure(Sender: TObject; var CanChange: Boolean;
var Pt: TPoint) of object;
TCanChangeResizeEvent = procedure(Sender: TObject; Style: TChangeSizeStyle;
var CanChange: Boolean; var Pt: TPoint) of object;
//***********************************************************************//
// //
// 尺寸修改方块类 //
// //
//***********************************************************************//
type
TCustomChangeSizeBox = class(TCustomControl)
private
FSize: Integer;
FStyle: TChangeSizeStyle;
FOnCanChangeSize: TCanChangeEvent;
procedure SetSize(const Value: Integer);
procedure WMLButtonDown(var Message: TWMLBUTTONDOWN); message WM_LBUTTONDOWN;
procedure WMLButtonUp(var Message: TWMLButtonUp); message WM_LBUTTONUP;
procedure WMMouseMove(var Message: TWMMouseMove); message WM_MOUSEMOVE;
protected
// 当前是否在改变尺寸
IsChangeSize: Boolean;
// 鼠标左键按下后所处一位置
OldPt: TPoint;
// 屏蔽属性
property Width;
property Height;
// 设置新的位置
procedure SetNewPos(const Pt: TPoint); virtual;
public
constructor Create(AOwner: TComponent); override;
property Color;
property Visible;
property Cursor;
property Size: Integer read FSize write SetSize;
property Style: TChangeSizeStyle read FStyle write FStyle;
property OnCanChangeSize: TCanChangeEvent read FOnCanChangeSize write FOnCanChangeSize;
end;
Top
-----------------------------------------------------------------------------
//***********************************************************************//
// //
// 选择框类 //
// //
//***********************************************************************//
type
TTransSelectFrame = class(TGraphicControl)
private
FActive: Boolean;
FOnActive: TNotifyEvent;
FOnMove: TNotifyEvent;
FOnCanMove: TCanChangeEvent;
FOnCanResize: TCanChangeResizeEvent;
FData: Pointer;
FParentObject: DWORD;
procedure SetcsbBottomCursor(const Value: TCursor);
procedure SetcsbLeftBottomCursor(const Value: TCursor);
procedure SetcsbLeftCursor(const Value: TCursor);
procedure SetcsbLeftTopCursor(const Value: TCursor);
procedure SetcsbRightBottomCursor(const Value: TCursor);
procedure SetcsbRightCursor(const Value: TCursor);
procedure SetcsbRightTopCursor(const Value: TCursor);
procedure SetcsbTopCursor(const Value: TCursor);
function GetcsbBottomCursor: TCursor;
function GetcsbLeftBottomCursor: TCursor;
function GetcsbLeftCursor: TCursor;
function GetcsbLeftTopCursor: TCursor;
function GetcsbRightBottomCursor: TCursor;
function GetcsbRightCursor: TCursor;
function GetcsbRightTopCursor: TCursor;
function GetcsbTopCursor: TCursor;
procedure SetActive(const Value: Boolean);
function GetVisible: Boolean;
procedure SetVisible(const Value: Boolean);
function GetColor: TColor;
procedure SetColor(const Value: TColor);
function GetStyle: TPenStyle;
procedure SetStyle(const Value: TPenStyle);
function GetCursor: TCursor;
function GetOnActive: TNotifyEvent;
function GetOnMove: TNotifyEvent;
procedure SetCursor(const Value: TCursor);
procedure SetOnActive(const Value: TNotifyEvent);
procedure SetOnMove(const Value: TNotifyEvent);
function GetOnResize: TNotifyEvent;
procedure SetOnResize(const Value: TNotifyEvent);
function GetActive: Boolean;
function GetParent: TWinControl;
function GetHeight: Integer;
function GetLeft: Integer;
function GetTop: Integer;
function GetWidth: Integer;
procedure SetHeight(const Value: Integer);
procedure SetLeft(const Value: Integer);
procedure SetTop(const Value: Integer);
procedure SetWidth(const Value: Integer);
function GetOnCanMove: TCanChangeEvent;
function GetOnCanResize: TCanChangeResizeEvent;
procedure SetOnCanMove(const Value: TCanChangeEvent);
procedure SetOnCanResize(const Value: TCanChangeResizeEvent);
procedure SetData(const Value: Pointer);
function GetData: Pointer;
protected
OldPt: TPoint;
// 当前是否在改变尺寸
// IsChangerSize: Boolean;
// 当前是否在移动
IsMove: Boolean;
// 八个方向的尺寸改变方块
ChangeBoxs: Array[wayLeftTop..wayTop] of TCustomChangeSizeBox;
procedure Paint; override;
procedure SetParent(AParent: TWinControl); override;
// 设置尺寸方块的新位置
procedure SetBoxPos; virtual;
procedure CanChange(Sender: TObject; var CanChange: Boolean;
var Pt: TPoint); virtual;
// 设置尺寸方块的可见性
procedure SetBoxVisible; virtual;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer); override;
procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer); override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
property Left: Integer read GetLeft write SetLeft;
property Top: Integer read GetTop write SetTop;
property Width: Integer read GetWidth write SetWidth;
property Height: Integer read GetHeight write SetHeight;
property Parent: TWinControl read GetParent write SetParent;
property Active: Boolean read GetActive write SetActive;
property Cursor: TCursor read GetCursor write SetCursor;
property Style: TPenStyle read GetStyle write SetStyle;
property Color: TColor read GetColor write SetColor;
property Visible: Boolean read GetVisible write SetVisible;
property Data: Pointer read GetData write SetData;
property csbLeftTopCursor: TCursor read GetcsbLeftTopCursor write SetcsbLeftTopCursor;
property csbLeftCursor: TCursor read GetcsbLeftCursor write SetcsbLeftCursor;
property csbLeftBottomCursor: TCursor read GetcsbLeftBottomCursor write SetcsbLeftBottomCursor;
property csbBottomCursor: TCursor read GetcsbBottomCursor write SetcsbBottomCursor;
property csbRightBottomCursor: TCursor read GetcsbRightBottomCursor write SetcsbRightBottomCursor;
property csbRightCursor: TCursor read GetcsbRightCursor write SetcsbRightCursor;
property csbRightTopCursor: TCursor read GetcsbRightTopCursor write SetcsbRightTopCursor;
property csbTopCursor: TCursor read GetcsbTopCursor write SetcsbTopCursor;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnActive: TNotifyEvent read GetOnActive write SetOnActive;
property OnResize: TNotifyEvent read GetOnResize write SetOnResize;
property OnMove: TNotifyEvent read GetOnMove write SetOnMove;
property OnCanResize: TCanChangeResizeEvent read GetOnCanResize write SetOnCanResize;
property OnCanMove: TCanChangeEvent read GetOnCanMove write SetOnCanMove;
end;
--------------------------------------------------------
implementation
{ TChangeSizeBox }
//***********************************************************************//
// //
// 构造函数 //
// //
//***********************************************************************//
constructor TCustomChangeSizeBox.Create(AOwner: TComponent);
begin
inherited;
// 设置初始尺寸
Self.Size := 5;
Self.Color := clWhite;
Self.FStyle := csbLeftTop;
Self.IsChangeSize := False;
Self.FOnCanChangeSize := NIL;
Self.Visible := True;
Self.ParentFont := False;
end;
//***********************************************************************//
// //
// 设置移动方块的新座标 //
// 参数: //
// Pt : 新的位置 //
// 返回值: 无 //
// //
//***********************************************************************//
procedure TCustomChangeSizeBox.SetNewPos(const Pt: TPoint);
begin
// 设置新的位置
case Self.FStyle of
// 左上
csbLeftTop:
begin
Self.Left := Pt.X - CNS_STATIC_TWO;
Self.Top := Pt.Y - CNS_STATIC_TWO;
end;
// 左
csbLeft:
begin
Self.Left := Pt.X - CNS_STATIC_TWO;
end;
// 左下
csbLeftBottom:
begin
Self.Left := Pt.X - CNS_STATIC_TWO;
Self.Top := Pt.Y - CNS_STATIC_THREE;
end;
// 下
csbBottom:
begin
Self.Top := Pt.Y - CNS_STATIC_THREE;
end;
// 右下
csbRightBottom:
begin
Self.Left := Pt.X - CNS_STATIC_THREE;
Self.Top := Pt.Y - CNS_STATIC_THREE;
end;
// 右
csbRight:
begin
Self.Left := Pt.X - CNS_STATIC_THREE;
end;
// 右上
csbRightTop:
begin
Self.Left := Pt.X - CNS_STATIC_THREE;
Self.Top := Pt.Y - CNS_STATIC_TWO;
end;
// 上
csbTop:
begin
Self.Top := Pt.Y - CNS_STATIC_TWO;
end;
end;
end;
//***********************************************************************//
// //
// 设置移动方块的尺寸 //
// 参数: //
// Value : 新尺寸 //
// 返回值: 无 //
// //
//***********************************************************************//
procedure TCustomChangeSizeBox.SetSize(const Value: Integer);
begin
if Self.FSize = Value then
Exit;
Self.FSize := Value;
// 设置新的长度和高度
Self.Width := Size;
Self.Height := Size;
end;
//***********************************************************************//
// //
// 处理鼠标左键按下消息 //
// //
//***********************************************************************//
procedure TCustomChangeSizeBox.WMLButtonDown(var Message: TWMLBUTTONDOWN);
var
Pt: TPoint;
begin
// 取鼠标位置
GetCursorPos(Pt);
// 转换座标
Pt := Self.Parent.ScreenToClient(Pt);
// 保存鼠标的原始位置
Self.OldPt := Point(Pt.X - Self.Left, Pt.Y - Self.Top);
// 捕捉鼠标
SetCapture(Self.Handle);
Self.IsChangeSize := True;
end;
//***********************************************************************//
// //
// 处理鼠标左键释放消息 //
// //
//***********************************************************************//
procedure TCustomChangeSizeBox.WMLButtonUp(var Message: TWMLButtonUp);
begin
// 不是拖动
Self.IsChangeSize := False;
// 释放鼠标
ReleaseCapture;
end;
//***********************************************************************//
// //
// 处理鼠标移动消息 //
// //
//***********************************************************************//
procedure TCustomChangeSizeBox.WMMouseMove(var Message: TWMMouseMove);
var
Pt: TPoint;
X, Y: Integer;
Can: Boolean;
begin
if not Self.IsChangeSize then
Exit;
// 取鼠标的位置
GetCursorPos(Pt);
// 座标转换
Pt := Self.Parent.ScreenToClient(Pt);
X := Pt.X - Self.OldPt.X;
Y := Pt.Y - Self.OldPt.Y;
Pt := Point(X, Y);
Can := True;
// 是否执行事件
if Assigned(Self.FOnCanChangeSize) then
begin
Self.FOnCanChangeSize(Self, Can, Pt);
end;
if NOT Can then
Exit;
// 设置新的位置
Self.SetNewPos(Pt);
end;
-------------------------------------------------------
asm
push p.Data
cmp pCount, 1
JB @exec
JE @One
cmp pCount, 2
JE @two
@ThreeUp:
CLD
mov ecx, pCount
sub ecx, 2
mov edx, 4
add edx, 4
@loop:
mov eax, [pParams]
mov eax, [eax]+edx
mov eax, [eax]
push eax
add edx, 4
Loop @loop
@Two:
mov ecx, [pParams]
mov ecx, [ecx]+4
mov ecx, [ecx]
@One:
mov edx, [pParams]//10//[DispParams(Params).rgvarg][0]//[pParams]
mov edx, [edx]
mov edx, [edx]
@exec:
mov eax, p.Data
cmp eax, 0
je @1
jne @call
@1:
mov eax, edx
mov edx, ecx
pop ecx
jmp @call
@call:
call P.Code
end;
