借鑑 學習 DELPHI 通用函數 哈哈
[轉]關於Delphi通用涵數
http://m.blog.csdn.net/blog/dragonjiang5460/1196927git
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;canvas
一個管理最近使用過的文件的類：
{-----------------------------------------------------------------------------
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.
windows
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-一、04/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;
- 1. 算法知識學習-----哈希（哈希函數與哈希表）
- 2. 哈希函數 哈希表
- 3. 哈希（哈希表與哈希函數）
- 4. 【Java】哈希表與哈希函數
- 5. 哈希函數——MD5
- 6. 哈希函數——SHA1
- 7. 哈希函數
- 8. 程序員才懂的58張圖片，哈哈哈哈哈哈哈哈哈哈哈哈哈哈哈
- 9. 哈希表和哈希函數和fileinputstream
- 10. 密碼學哈希函數
- 更多相關文章...
- • C# 哈希表（Hashtable） - C#教程
- • Redis哈希數據結構和常用命令 - Redis教程
- • 適用於PHP初學者的學習線路和建議
- • Tomcat學習筆記（史上最全tomcat學習筆記）
-
每一个你不满意的现在，都有一个你没有努力的曾经。
- 1. 算法知識學習-----哈希（哈希函數與哈希表）
- 2. 哈希函數 哈希表
- 3. 哈希（哈希表與哈希函數）
- 4. 【Java】哈希表與哈希函數
- 5. 哈希函數——MD5
- 6. 哈希函數——SHA1
- 7. 哈希函數
- 8. 程序員才懂的58張圖片，哈哈哈哈哈哈哈哈哈哈哈哈哈哈哈
- 9. 哈希表和哈希函數和fileinputstream
- 10. 密碼學哈希函數