关于Delphi通用涵数

技术2022-05-11 3

DELPHI程序注册码设计（转载）思路是这样的:程序运行时先检测注册表,如果找到注册项,则表明已经注册,如果没有找到注册项,则提示要求注册. <注册例程> 在DELPHI下新建一工程,放置Edit1,Edit2,Label1,Label2,Button1组件.具体代码如下: unit Unit1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls,Registry;//在此加上Registry以便调用注册表. type TForm1 = class(Tform) Button1: Tbutton; Edit1: Tedit; Edit2: Tedit; Label1: Tlabel; Label2: Tlabel; procedure Button1Click(Sender: Tobject); procedure FormCreate(Sender: Tobject); private Function Check():Boolean; Procedure CheckReg(); Procedure CreateReg(); { Private declarations } public { Public declarations } end; var Form1: TForm1; Pname:string; //全局变量,存放用户名和注册码. Ppass:integer; implementation {$R *.DFM} Procedure TForm1.CreateReg();//创建用户信息. var Rego:Tregistry; begin Rego:=Tregistry.Create; Rego.RootKey:=HKEY_USERS; rego.OpenKey(‘.DEFAULTSoftwareAngelSoftDemo‘,True);//键名为AngelSoftDemo,可自行修改. Rego.WriteString(‘Name‘,Pname);//写入用户名. Rego.WriteInteger(‘Pass‘,Ppass);//写入注册码. Rego.Free; ShowMessage(‘程序已经注册,谢谢!‘); CheckReg; //刷新. end; Procedure TForm1.CheckReg();//检查程序是否在注册表中注册. var Rego:Tregistry; begin Rego:=Tregistry.Create; Rego.RootKey:=HKEY_USERS; IF Rego.OpenKey(‘.DEFAULTSoftwareAngelSoftDemo‘,False) then begin Form1.Caption:=‘软件已经注册‘; Button1.Enabled:=false; Label1.Caption:=rego.ReadString(‘Name‘);//读用户名. Label2.Caption:=IntToStr(Rego.ReadInteger(‘Pass‘)); //读注册码. rego.Free; end else Form1.Caption:=‘软件未注册,请注册‘; end; Function TForm1.Check():Boolean;//检查注册码是否正确. var Temp:pchar; Name:string; c:char; I,Long,Pass:integer; begin Pass:=0; Name:=edit1.Text; long:=length(Name); for I:=1 to Long do begin temp:=pchar(copy(Name,I,1)); c:=temp^; Pass:=Pass+ord(c); //将用户名每个字符转换为ASCII码后相加. end; if StrToInt(Edit2.Text)=pass then begin Result:=True; Pname:=Name; Ppass:=Pass; end else Result:=False; end; procedure TForm1.Button1Click(Sender: Tobject); begin if Check then CreateReg else ShowMessage(‘注册码不正确,无法注册‘); end; procedure TForm1.FormCreate(Sender: Tobject); begin CheckReg; end; end. <注册器> 在DELPHI下新建一工程,放置Edit1,Edit2,Button1组件.具体代码如下: unit Unit1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; type TForm1 = class(Tform) Button1: Tbutton; Edit1: Tedit; Edit2: Tedit; procedure Button1Click(Sender: Tobject); private { Private declarations } public { Public declarations } end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.Button1Click(Sender: Tobject); var Temp:pchar; Name:string; c:char; I,Long,Pass:integer; begin Pass:=0; Name:=edit1.Text; long:=length(Name); for I:=1 to Long do begin temp:=pchar(copy(Name,I,1)); c:=temp^; Pass:=Pass+ord(c); end; edit2.text:=IntToStr(pass); end; end. 从<注册器>中取得注册码,便可在<注册例程>中进行注册.原理是使用ORD函数取得用户名每单个字符的ASCII码值,并进行相加得到注册码.

function FilterNumber(keyval: char; me: TEdit; dot, Minus: string; ExtLen: integer): boolean; var s: string; c: string; p: Integer; begin result := false; s := '0123456789'; c := keyval; if (dot = '.') then s := s + '.'; if (minus = '-') then s := s + '-'; if (c = dot) and (TRIM(me.text) = '') then Exit; if (c = dot) and (Pos(dot, me.text) > 0) then Exit; if (c = dot) and (trim(me.text) = minus) then Exit; if (c = minus) and (Pos(minus, me.Text) > 0) then Exit; if (c = minus) and (pos(minus, me.Text) < 1) and (Me.SelStart > 0) then Exit; if (c = minus) and (trim(me.Text) = dot) then Exit; result := (keyval = chr(vk_return)) or (keyval = Chr(vk_tab)) or (keyval = chr(VK_DELETE)) or (keyval = chr(VK_BACK)) or (Pos(c, s) > 0); p := Pos(dot, Me.Text + c); if (p > 0) then if (length(Me.text + c) - P) > ExtLen then result := (false) or (keyval = chr(vk_return)) or (keyval = Chr(vk_tab)) or (keyval = chr(VK_DELETE)) or (keyval = chr(VK_BACK)); end; procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char); begin if not filterNumber(key, Edit1, '.', '-', 6) then key := #0; end;

Top

//如何用代码自动建ODBC 以下是在程序中动态创建ODBC的DSN数据源代码： procedure TCreateODBCDSNfrm.CreateDSNBtnClick(Sender: TObject); var registerTemp : TRegistry; bData : array[ 0..0 ] of byte; begin registerTemp := TRegistry.Create; //建立一个Registry实例 with registerTemp do begin RootKey:=HKEY_LOCAL_MACHINE; //设置根键值为HKEY_LOCAL_MACHINE //找到Software/ODBC/ODBC.INI/ODBC Data Sources if OpenKey('Software/ODBC/ODBC.INI /ODBC Data Sources',True) then begin //注册一个DSN名称 WriteString( 'MyAccess', 'Microsoft Access Driver (*.mdb)' ); end else begin//创建键值失败 memo1.lines.add('增加ODBC数据源失败'); exit; end; CloseKey; //找到或创建Software/ODBC/ODBC.INI /MyAccess,写入DSN配置信息 if OpenKey('Software/ODBC/ODBC.INI /MyAccess',True) then begin WriteString( 'DBQ', 'C:/inetpub/wwwroot /test.mdb' );//数据库目录，连接您的数据库 WriteString( 'Description', '我的新数据源' );//数据源描述 WriteString( 'Driver', 'C:/PWIN98/SYSTEM/ odbcjt32.dll' );//驱动程序DLL文件 WriteInteger( 'DriverId', 25 ); //驱动程序标识 WriteString( 'FIL', 'Ms Access;' ); //Filter依据 WriteInteger( 'SafeTransaction', 0 ); //支持的事务操作数目 WriteString( 'UID', '' );//用户名称 bData[0] := 0; WriteBinaryData( 'Exclusive', bData, 1 ); //非独占方式 WriteBinaryData( 'ReadOnly', bData, 1 ); //非只读方式 end else//创建键值失败 begin memo1.lines.add('增加ODBC数据源失败'); exit; end; CloseKey; //找到或创建Software/ODBC/ODBC.INI /MyAccess/Engines/Jet //写入DSN数据库引擎配置信息 if OpenKey('Software/ODBC/ODBC.INI /MyAccess/Engines/Jet',True) then begin WriteString( 'ImplicitCommitSync', 'Yes' ); WriteInteger( 'MaxBufferSize', 512 );//缓冲区大小 WriteInteger( 'PageTimeout', 10 );//页超时 WriteInteger( 'Threads', 3 );//支持的线程数目 WriteString( 'UserCommitSync', 'Yes' ); end else//创建键值失败 begin memo1.lines.add('增加ODBC数据源失败'); exit; end; CloseKey; memo1.lines.add('增加新ODBC数据源成功'); Free; end; end;

一个管理最近使用过的文件的类： {----------------------------------------------------------------------------- Unit Name: RcntFileMgr Author: tony Purpose: Manager the recent file list. History: 2004.06.08 create -----------------------------------------------------------------------------} unit RcntFileMgr; interface uses Classes, SysUtils, Inifiles; type TRecentFileChangedEvent = procedure(Sender:TObject) of object; TRecentFileManager=class(TObject) private FRecentFileList:TStringList; FMaxRecentCount:Integer; FOnRecentFileChanged:TRecentFileChangedEvent; protected function GetRecentFileCount():Integer; function GetRecentFile(Index:Integer):String; procedure LoadFromConfigFile(); procedure SaveToConfigFile(); public constructor Create(); destructor Destroy();override; procedure AddRecentFile(const AFileName:String); property RecentFileCount:Integer read GetRecentFileCount; property RecentFile[Index:Integer]:String read GetRecentFile; property OnRecentFileChanged:TRecentFileChangedEvent read FOnRecentFileChanged write FOnRecentFileChanged; end; implementation { TRecentFileManager } function TRecentFileManager.GetRecentFileCount():Integer; begin Result:=FRecentFileList.Count; end; function TRecentFileManager.GetRecentFile(Index:Integer):String; begin Result:=FRecentFileList.Strings[Index]; end; procedure TRecentFileManager.LoadFromConfigFile(); var Ini:TInifile; KeyList:TStringList; I:Integer; begin Ini:=TInifile.Create(ExtractFilePath(ParamStr(0))+'config.ini'); KeyList:=TStringList.Create(); try Ini.ReadSection('RecentFile',KeyList); for I:=0 to KeyList.Count-1 do begin FRecentFileList.Add(Ini.ReadString('RecentFile',KeyList.Strings[I],'')); end; if Assigned(FOnRecentFileChanged) then begin FOnRecentFileChanged(self); end; finally Ini.Free; KeyList.Free; end; end; procedure TRecentFileManager.SaveToConfigFile(); var Ini:TInifile; I:Integer; begin Ini:=TInifile.Create(ExtractFilePath(ParamStr(0))+'config.ini'); try Ini.EraseSection('RecentFile'); for I:=0 to FRecentFileList.Count-1 do begin Ini.WriteString('RecentFile','Recent'+IntToStr(I),FRecentFileList.Strings[I]); end; finally Ini.Free; end; end; constructor TRecentFileManager.Create(); begin inherited Create(); FRecentFileList:=TStringList.Create(); FMaxRecentCount:=5; LoadFromConfigFile(); end; destructor TRecentFileManager.Destroy(); begin if Assigned(FRecentFileList) then begin try SaveToConfigFile(); except //ignore any exceptions end; FreeAndNil(FRecentFileList); end; inherited Destroy(); end; procedure TRecentFileManager.AddRecentFile(const AFileName:String); var RecentIndex:Integer; begin RecentIndex:=FRecentFileList.IndexOf(AFileName); if RecentIndex>=0 then begin FRecentFileList.Delete(RecentIndex); end; FRecentFileList.Insert(0,AFileName); while FRecentFileList.Count>FMaxRecentCount do begin FRecentFileList.Delete(FRecentFileList.Count-1); end; if Assigned(FOnRecentFileChanged) then begin FOnRecentFileChanged(self); end; end; end.

Top9楼 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.

Top16楼 GreatSuperYoyoNC (ExSystem|麻烦结帖[-_-]) 回复于 2004-07-20 16:11:30 得分 0

//--[Yoyoworks]---------------------------------------------------------------- //工程名称：prjPowerFlashPlayer //软件名称：iPowerFlashPlayer //单元作者：许子健 //开始日期：2004年03月14日，14:31:16 //单元功能：用于音量调整的类。 //-----------------------------------------------------------[SHANGHAi|CHiNA]-- Unit untTVolume; Interface Uses MMSystem, SysUtils; Type TVolume = Class(TObject) Private FVolume: LongInt; //存储音量。 FIsMute: Boolean; //存储静音值。 Procedure SetLeftVolume(Volume: Integer); //设置左声道的音量。 Function GetLeftVolume: Integer; //获得左声道的音量。 Procedure SetRightVolume(Volume: Integer); //设置右声道的音量。 Function GetRightVolume: Integer; //获得右声道的音量。 Procedure SetIsMute(IsMute: Boolean); //设置是否静音。 Public Constructor Create; Destructor Destroy; Override; Published Property LeftVolume: Integer Read GetLeftVolume Write SetLeftVolume; Property RightVolume: Integer Read GetRightVolume Write SetRightVolume; Property Mute: Boolean Read FIsMute Write SetIsMute; End; Implementation // ----------------------------------------------------------------------------- // 过程名： TVolume.Create // 参数：无 // 返回值：无 // ----------------------------------------------------------------------------- Constructor TVolume.Create; Begin Inherited Create; FVolume := 0; FIsMute := False; //初始化变量 waveOutGetVolume(0, @FVolume); //得到现在音量 End; // ----------------------------------------------------------------------------- // 过程名： TVolume.Destroy // 参数：无 // 返回值：无 // ----------------------------------------------------------------------------- Destructor TVolume.Destroy; Begin Inherited Destroy; End; // ----------------------------------------------------------------------------- // 过程名： TVolume.SetLeftVolume // 参数： Volume: Integer // 返回值：无 // ----------------------------------------------------------------------------- Procedure TVolume.SetLeftVolume(Volume: Integer); Begin If (Volume < 0) Or (Volume > 255) Then Raise Exception.Create('Range error of the left channel [0 to 255].'); //如果“Volume”参数不在0至255的范围里，则抛出异常。 If FIsMute = False Then Begin waveOutGetVolume(0, @FVolume); //@示指向变量Volume的指针（32位），调用此函数的用意就是得到右声道的值，做到在调节左声道的时候，不改变右声道。 FVolume := FVolume And $FFFF0000 Or (Volume Shl 8); //数字前加$表示是十六进制 waveOutSetVolume(0, FVolume); End //如果不是静音状态，则改变音量； Else FVolume := FVolume And $FFFF0000 Or (Volume Shl 8); //否则，只改变变量。 End; // ----------------------------------------------------------------------------- // 过程名： TVolume.SetRightVolume // 参数： Volume: Integer // 返回值：无 // ----------------------------------------------------------------------------- Procedure TVolume.SetRightVolume(Volume: Integer); Begin If (Volume < 0) Or (Volume > 255) Then Raise Exception.Create('Range error of the right channel [0 to 255].'); If FIsMute = False Then Begin waveOutGetVolume(0, @FVolume); FVolume := FVolume And $0000FFFF Or (Volume Shl 24); waveOutSetVolume(0, FVolume); End Else FVolume := FVolume And $0000FFFF Or (Volume Shl 24); End; // ----------------------------------------------------------------------------- // 过程名： TVolume.SetIsMute // 参数： IsMute: Boolean // 返回值：无 // ----------------------------------------------------------------------------- Procedure TVolume.SetIsMute(IsMute: Boolean); Begin FIsMute := IsMute; If FIsMute = True Then waveOutSetVolume(0, 0) Else waveOutSetVolume(0, FVolume); End; // ----------------------------------------------------------------------------- // 函数名： TVolume.GetLeftVolume // 参数：无 // 返回值： Integer // ----------------------------------------------------------------------------- Function TVolume.GetLeftVolume: Integer; Begin If FIsMute = False Then waveOutGetVolume(0, @FVolume); //得到现在音量 Result := Hi(FVolume); //转换成数字 End; // ----------------------------------------------------------------------------- // 函数名： TVolume.GetRightVolume // 参数：无 // 返回值： Integer // ----------------------------------------------------------------------------- Function TVolume.GetRightVolume: Integer; Begin If FIsMute = False Then waveOutGetVolume(0, @FVolume); //得到现在音量 Result := Hi(FVolume Shr 16); //转换成数字 End; End.

点击DBGrid的Title对查询结果排序关键词:DBGrid 排序欲实现点击DBGrid的Title对查询结果排序，想作一个通用程序，不是一事一议，例如不能在SQL语句中增加Order by ...，因为SQL可能原来已经包含Order by ...，而且点击另一个Title时又要另外排序，目的是想作到象资源管理器那样随心所欲。 procedure TFHkdata.SortQuery(Column:TColumn); var SqlStr,myFieldName,TempStr: string; OrderPos: integer; SavedParams: TParams; begin if not (Column.Field.FieldKind in [fkData,fkLookup]) then exit; if Column.Field.FieldKind =fkData then myFieldName := UpperCase(Column.Field.FieldName) else myFieldName := UpperCase(Column.Field.KeyFields); while Pos(myFieldName,';')<>0 do myFieldName := copy(myFieldName,1,Pos(myFieldName,';')-1)+ ',' + copy(myFieldName,Pos(myFieldName,';')+1,100); with TQuery(TDBGrid(Column.Grid).DataSource.DataSet) do begin SqlStr := UpperCase(Sql.Text); // if pos(myFieldName,SqlStr)=0 then exit; if ParamCount>0 then begin SavedParams := TParams.Create; SavedParams.Assign(Params); end; OrderPos := pos('ORDER',SqlStr); if (OrderPos=0) or (pos(myFieldName,copy(SqlStr,OrderPos,100))=0) then TempStr := ' Order By ' + myFieldName + ' Asc' else if pos('ASC',SqlStr)=0 then TempStr := ' Order By ' + myFieldName + ' Asc' else TempStr := ' Order By ' + myFieldName + ' Desc'; if OrderPos<>0 then SqlStr := Copy(SqlStr,1,OrderPos-1); SqlStr := SqlStr + TempStr; Active := False; Sql.Clear; Sql.Text := SqlStr; if ParamCount>0 then begin Params.AssignValues(SavedParams); SavedParams.Free; end; Prepare; Open; end; end; 去掉DbGrid的自动添加功能移动到最后一条记录时再按一下“下”就会追加一条记录，如果去掉这项功能 procedure TForm1.DataSource1Change(Sender: TObject; Field: TField); begin if TDataSource(Sender).DataSet.Eof then TDataSource(Sender).DataSet.Cancel; end; DBGrid不支持鼠标的上下移动的解决代码自己捕捉WM_MOUSEWHEEL消息处理 private OldGridWnd : TWndMethod; procedure NewGridWnd (var Message : TMessage); public procedure TForm1.NewGridWnd(var Message: TMessage); var IsNeg : Boolean; begin if Message.Msg = WM_MOUSEWHEEL then begin IsNeg := Short(Message.WParamHi) < 0; if IsNeg then DBGrid1.DataSource.DataSet.MoveBy(1) else DBGrid1.DataSource.DataSet.MoveBy(-1) end else OldGridWnd(Message); end; procedure TForm1.FormCreate(Sender: TObject); begin OldGridWnd := DBGrid1.WindowProc ; DBGrid1.WindowProc := NewGridWnd; end; dbgrid中移动焦点到指定的行和列 dbgrid是从TCustomGrid继承下来的，它有col与row属性，只不过是protected的，不能直接访问，要处理一下，可以这样： TDrawGrid(dbgrid1).row:=row; TDrawGrid(dbgrid1).col:=col; dbgrid1.setfocus; 就可以看到效果了。 1 这个方法是绝对有问题的，它会引起DBGrid内部的混乱，因为DBGrid无法定位当前纪录，如果DBGrid只读也就罢了（只读还是会出向一些问题，比如原本只能单选的纪录现在可以出现多选等等，你可以自己去试试），如果DBGrid可编辑那问题就可大了，因为当前纪录的关系，你更改的数据字段很可能不是你想象中的 2 我常用的解决办法是将上程序改为（随便设置col是安全的，没有一点问题） Query1.first; TDrawGrid(dbgrid1).col:=1; dbgrid1.setfocus; 这就让焦点移到第一行第一列当中如何使DBGRID网格的颜色随此格中的数据值的变化而变化？在做界面的时候，有时候为了突出显示数据的各个特性（如过大或者过小等），需要通过改变字体或者颜色，本文就是针对这个情况进行的说明。如何使DBGRID网格的颜色随此格中的数据值的变化而变化。如<60的网格为红色？ Delphi中数据控制构件DBGrid是用来反映数据表的最重要、也是最常用的构件。在应用程序中，如果以彩色的方式来显示DBGrid，将会增加其可视性，尤其在显示一些重要的或者是需要警示的数据时，可以改变这些数据所在的行或列的前景和背景的颜色。　　DBGrid属性DefaultDrawing是用来控制Cell（网格）的绘制。若DefaultDrawing的缺省设置为True，意思是Delphi使用DBGrid的缺省绘制方法来制作网格和其中所包含的数据，数据是按与特定列相连接的Tfield构件的DisplayFormat或EditFormat特性来绘制的；若将DBGrid的DefaultDrawing特性设置成False，Delphi就不绘制网格或其内容，必须自行在TDBGrid的OnDrawDataCell事件中提供自己的绘制例程（自画功能）。　　在这里将用到DBGrid的一个重要属性：画布Canvas，很多构件都有这一属性。Canvas代表了当前被显示DBGrid的表面，你如果把另行定义的显示内容和风格指定给DBGrid对象的Canvas，DBGrid对象会把Canvas属性值在屏幕上显示出来。具体应用时，涉及到Canvas的Brush属性和FillRect方法及TextOut方法。Brush属性规定了DBGrid.Canvas显示的图像、颜色、风格以及访问Windows GDI 对象句柄，FillRect方法使用当前Brush属性填充矩形区域，方法TextOut输出Canvas的文本内容。　　以下用一个例子来详细地说明如何显示彩色的DBGrid。在例子中首先要有一个DBGrid构件，其次有一个用来产生彩色筛选条件的SpinEdit构件，另外还有ColorGrid构件供自由选择数据单元的前景和背景的颜色。　　1.建立名为ColorDBGrid的Project，在其窗体Form1中依次放入所需构件，并设置属性为相应值，具体如下所列：　　 Table1 DatabaseName: DBDEMOS TableName: EMPLOYEE.DB Active: True; 　　DataSource1 DataSet: Table1 　　DBGrid1 DataSource1: DataSource1 DefaultDrawing: False 　　SpinEdit1 Increment:200 Value: 20000 　　ColorGrid1 GridOrdering: go16＊1 　　2.为DBGrid1构件OnDrawDataCell事件编写响应程序： //这里编写的程序是<60的网格为红色的情况，其他的可以照此类推　　procedure TForm1.DBGrid1DrawDataCell(Sender: TObject; const Rect: TRect;Field: TField; State: TGridDrawState); 　　begin 　　 if Table1.Fieldbyname(′Salary′).value<=SpinEdit1.value then 　　 DBGrid1.Canvas.Brush.Color:=ColorGrid1.ForeGroundColor 　　 else 　　 DBGrid1.Canvas.Brush.Color:=ColorGrid1.BackGroundColor; 　　 DBGrid1.Canvas.FillRect(Rect); 　　 DBGrid1.Canvas.TextOut(Rect.left＋2,Rect.top＋2,Field.AsString); 　　end; 　　这个过程的作用是当SpinEdit1给定的条件得以满足时，如′salary′变量低于或等于SpinEdit1.Value时，DBGrid1记录以ColorGrid1的前景颜色来显示，否则以ColorGrid1的背景颜色来显示。然后调用DBGrid的Canvas的填充过程FillRect和文本输出过程重新绘制DBGrid的画面。　　3.为SpinEdit1构件的OnChange事件编写响应代码：　　procedure TForm1.SpinEdit1Change(Sender: TObject); 　　begin 　　 DBGrid1.refresh; //刷新是必须的，一定要刷新哦　　end; 　　当SpinEdit1构件的值有所改变时，重新刷新DBGrid1。　　4.为ColorGrid1的OnChange事件编写响应代码：　　procedure TForm1.ColorGrid1Change(Sender: TObject); 　　begin 　　 DBGrid1.refresh; //刷新是必须的，一定要刷新哦　 end; 　　当ColorGrid1的值有所改变时，即鼠标的右键或左键单击ColorGrid1重新刷新DBGrid1。　　5.为Form1窗体（主窗体）的OnCreate事件编写响应代码：　　procedure TForm1.FormCreate(Sender: TObject); 　　begin 　　 ColorGrid1.ForeGroundIndex:=9; 　　 ColorGrid1.BackGroundIndex:=15; 　end; 　　在主窗创建时，将ColorGrid1的初值设定前景为灰色，背景为白色，也即DBGrid的字体颜色为灰色，背景颜色为白色。　　6.现在，可以对ColorDBGrid程序进行编译和运行了。当用鼠标的左键或右键单击ColorGrid1时，DBGrid的字体和背景颜色将随之变化。　　在本文中，只是简单展示了以彩色方式显示DBGrid的原理，当然，还可以增加程序的复杂性，使其实用化。同样道理，也可以将这个方法扩展到其他拥有Canvas属性的构件中，让应用程序的用户界面更加友好。判断Grid是否有滚动条？这是一个小技巧，如果为了风格的统一的话，还是不要用了。：）。。。 if (GetWindowlong(Stringgrid1.Handle, GWL_STYLE) and WS_VSCROLL) <> 0 then ShowMessage('Vertical scrollbar is visible!'); if (GetWindowlong(Stringgrid1.Handle, GWL_STYLE) and WS_HSCROLL) <> 0 then ShowMessage('Horizontal scrollbar is visible!'); 。。。

{================================================================= 功能: 返回网络中SQLServer列表参数: List: 需要填充的List 返回值: 成功: True,并填充List 失败 False =================================================================} Function GetSQLServerList(var List: Tstringlist): boolean; var i: integer; SQLServer: Variant; ServerList: Variant; begin Result := False; List.Clear; try SQLServer := CreateOleObject('SQLDMO.Application'); ServerList := SQLServer.ListAvailableSQLServers; for i := 1 to Serverlist.Count do list.Add (Serverlist.item(i)); Result := True; Finally SQLServer :=null; ServerList :=null; end; end;

如何获取局域网中的所有 SQL Server 服务器文献参考来源：Delphi 深度探索我一直想在我的应用程序中获得关于 SQL Server 更详细的信息。直到最近利用 SQLDMO(SQL Distributed Management Objects) 才得以实现这个想法。SQLDMO 提供了非常强大的功能，我们几乎可以利用程序实现任何 SQL Server 拥有的功能。在这篇文章中我将向您展示如何得到局域网中所有 SQL Servers 服务器、如何连接、如何获得服务器中的所有数据库。 SQLDMO 对像来自 SQL Server 2000 提供的动态连接库 SQLDMO.dll。这个 dll 本身是一个 COM 对像，首先你必须从类型库中引用Microsoft SQLDMO Object Library (Version 8.0). Delphi 会自动为你生成SQLDMO_TLB.PAS文件,文件中包括了所有 COM 对象的接口。在这里我们需要注意，由于引入的SQLDMO “TDatabase”和 “TApplication”和其它几个缺省类名与 Delphi 自带的类名冲突，所以自己可以修改成 _TypeName 的形式。或者其它的名字，我在这里改成 T_Application 、T_Database 等。我们下一步要做的是在我们的程序中引入单元文件 SQLDMO_TLB.PAS 。应用程序单元名称是 SqlServers 程序运行界面如下：服务器列表中是局域网中所有的 SQL SERVER 服务器,选择服务器后输入用户名和密码，下拉数据库列表，程序会列出此服务器中的所有数据库. 程序源代码如下： unit SqlServers; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, Buttons, ComCtrls , SQLDMO_TLB;//注意别忘了引入此文件 type TdmoObject = record SQL_DMO : _SQLServer; lConnected : boolean; end; type TFormServersList = class(TForm) Label1: TLabel; Label2: TLabel; CB_ServerNames: TComboBox; CB_DataNames: TComboBox; Label3: TLabel; Label4: TLabel; Ed_Login: TEdit; Ed_Pwd: TEdit; BitBtn1: TBitBtn; BitBtn2: TBitBtn; procedure FormCreate(Sender: TObject); procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean); procedure FormClose(Sender: TObject; var Action: TCloseAction); procedure FormShow(Sender: TObject); procedure BitBtn2Click(Sender: TObject); procedure CB_DataNamesDropDown(Sender: TObject); private server_Names : TStringList; //对象集合 PdmoObject : array of TdmoObject; //获取所有的远程服务器 Function GetAllServers(ServerList : TStringList) : Boolean; { Private declarations } public { Public declarations } end; var FormServersList: TFormServersList; implementation {$R *.DFM} { TForm1 } Function TFormServersList.GetAllServers(ServerList : TStringList) : Boolean; var sApp : _Application ; sName : NameList; iPos : integer; begin Result := True ; try sApp := CoApplication_.Create ; //创建的对象不用释放，delphi 自己会释放 sName := sApp.ListAvailableSQLServers; except Result := False; Exit; end; if sName.Count > 0 then // 之所以　iPos 从１开始,是因为0 位置为空值即 ' ' for iPos := 1 to sName.Count - 1 do begin CB_ServerNames.Items.Add(sName.Item(iPos)); ServerList.Add(sName.Item(iPos)); end; end; procedure TFormServersList.FormCreate(Sender: TObject); var lcv : integer; begin server_Names := TStringList.Create; if not GetAllServers(server_Names) then begin Application.MessageBox('无法获取服务器列表,可能缺少客户端DLL库函数','错误提示',MB_OK); exit; end; for lcv := 0 to server_Names.Count - 1 do begin SetLength(PdmoObject,lcv + 1); with PdmoObject[lcv] do begin SQL_DMO := CoSQLServer.Create; SQL_DMO.Name := Trim(server_Names[lcv]); //登陆安全属性，NT 身份验证 SQL_DMO.LoginSecure := false; // 设置一个连接超时 SQL_DMO.LoginTimeout := 3; //自动重新登陆，如果第一次失败后 SQL_DMO.AutoReconnect := true; SQL_DMO.ApplicationName := server_Names[lcv]; lConnected := false; end; end; end; procedure TFormServersList.FormCloseQuery(Sender: TObject; var CanClose: Boolean); begin server_Names.Free; end; procedure TFormServersList.FormClose(Sender: TObject; var Action: TCloseAction); begin Action := CaFree; end; procedure TFormServersList.FormShow(Sender: TObject); begin if CB_ServerNames.Items.Count > 0 then //列举所有服务器名字 CB_ServerNames.Text := CB_ServerNames.Items.Strings[0]; end; procedure TFormServersList.BitBtn2Click(Sender: TObject); begin Close ; end; procedure TFormServersList.CB_DataNamesDropDown(Sender: TObject); var icount ,Server_B : integer; begin CB_DataNames.Clear; Screen.Cursor := CrHourGlass; Server_B := CB_ServerNames.Items.IndexOf(CB_ServerNames.Text) ; with PdmoObject[Server_B].SQL_DMO do begin if not PdmoObject[Server_B].lConnected then try Connect(Name,Trim(Ed_Login.Text),Trim(Ed_Pwd.Text)); except Screen.Cursor := CrDefault ; Application.MessageBox('请检查用户名或密码是否正确','连接失败',MB_OK); Exit ; end; if not VerifyConnection(SQLDMOConn_ReconnectIfDead) then begin ShowMessage('在试图连接到SQL SERVER 2000 时出现错误' + #10#13 + '确信是否加在了动态连接库SQLDMO.DLL'); exit; end else PdmoObject[Server_B].lConnected := True ; Databases.Refresh(true); for icount := 1 to Databases.Count do CB_DataNames.Items.Add(Databases.Item(icount,null).name); end; Screen.Cursor := CrDefault ; end end.

一个使用了OpenGL的3D空间浏览程序。 unit Unit1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,OpenGL, ExtCtrls, StdCtrls, Buttons,math; type TGLPoint3D=packed array[0..2] of GLFloat; TPoint3D=record x,y,z:Integer; color:Integer; end; TLineClash=record TestLines:array[0..1] of Integer; MaxX,MinX:GLFloat; TestK,TestS:GLFloat; end; TPGLPoint3D=^TGLPoint3D; T3DObject=packed record ID:Integer; x,y,z,Orientx,Orienty,Orientz:Real; PointsNum:Integer; ClashsNum:Integer; Clashs:array of TLineClash; Points:array of TGLPoint3D; end; TP3DObject=^T3DObject; TPerson=record orientx,orienty,orientz:Real; oldp,newp:TGLPoint3D; end; TForm1 = class(TForm) Timer1: TTimer; Panel1: TPanel; procedure FormCreate(Sender: TObject); procedure FormClose(Sender: TObject; var Action: TCloseAction); procedure Panel1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); procedure FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); procedure Panel1Resize(Sender: TObject); procedure Timer1Timer(Sender: TObject); private { Private declarations } public { Public declarations } DC:HDC; hglrc:HGLRC; mdx,mdy:Integer; numofpoints:Integer; points:array[0..$ffff] of TPoint3D; person:TPerson; objs:array[0..100] of T3DObject; procedure InitOpenGL; procedure UninitOpenGL; procedure DrawPic; procedure DrawPic2; procedure DrawObject(pObj:TP3DObject); procedure InitObjects; function TestClash(pObj:TP3DObject;var p1,p2:TGLPoint3D):Boolean; end; const MaxWidth=300.0;MaxHeight=300.0;MaxDepth=300.0; LeftKey=37; UpKey=37; RightKey=37; DownKey=37; ps:packed array[0..3] of TGLPoint3D=((0.0,0.0,0.0),(0.0,1.0,0.0),(-5.0,0.0,0.0),(-5.0,1.0,0.0)); var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.InitOpenGL; var pfd:PIXELFORMATDESCRIPTOR; pf:Integer; begin with pfd do begin nSize:=sizeof(PIXELFORMATDESCRIPTOR); nVersion:=1; dwFlags:= PFD_DRAW_TO_WINDOW or PFD_SUPPORT_OPENGL or PFD_DOUBLEBUFFER; iPixelType:= PFD_TYPE_RGBA; cColorBits:= 24; cRedBits:= 0; cRedShift:= 0; cGreenBits:= 0; cGreenShift:= 0; cBlueBits:= 0; cBlueShift:= 0; cAlphaBits:= 0; cAlphaShift:= 0; cAccumBits:=0; cAccumRedBits:= 0; cAccumGreenBits:= 0; cAccumBlueBits:= 0; cAccumAlphaBits:= 0; cDepthBits:= 32; cStencilBits:= 0; cAuxBuffers:= 0; iLayerType:= PFD_MAIN_PLANE; bReserved:= 0; dwLayerMask:= 0; dwVisibleMask:= 0; dwDamageMask:= 0; end; DC:=GetWindowDC(Panel1.Handle); pf:=ChoosePixelFormat(DC,@pfd); SetPixelFormat(DC,pf,@pfd); hglrc:=wglCreateContext(DC); wglMakeCurrent(DC,hglrc); glMatrixMode(GL_PROJECTION); glLoadIdentity; glEnable(GL_DEPTH_TEST); end; procedure TForm1.UninitOpenGL; begin if hglrc<>0 then wglDeleteContext(hglrc); end; procedure TForm1.FormCreate(Sender: TObject); begin person.orientx :=0; person.orienty :=0; person.orientz :=0; person.newp[0]:=0.0; person.newp[1]:=1.2; person.newp[2]:=-5.0; person.oldp[0]:=0.0; person.oldp[1]:=1.2; person.oldp[2]:=0.0; InitObjects; InitOpenGL; end; procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction); begin UninitOpenGL; end; procedure TForm1.DrawPic; var i:Integer; begin glClear(GL_COLOR_BUFFER_BIT); glBegin(GL_POINTS); for i:=0 to numofpoints-1 do begin glColor3ubv(@(points[i].color)); glVertex3d(points[i].x/MaxWidth,points[i].y/MaxHeight,points[i].z/MaxDepth); end; glEnd; glEnable(GL_DEPTH_TEST); glClear(GL_DEPTH_BUFFER_BIT); glFlush; SwapBuffers(DC); end;

procedure TForm1.Panel1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin mdx:=X; mdy:=Y; end; procedure TForm1.DrawPic2; const MaxX=90.0; MinX=-90.0; MaxZ=90.0; MinZ=-90.0; StepX=(MaxX-MinX)/100; StepZ=(MaxZ-MinZ)/100; var i:Real; gp:GLUquadricObj; j:Integer; begin glClearColor(0.0,0.0,0.0,0.0); glClear(GL_COLOR_BUFFER_BIT); glColor3f(1.0,1.0,0.0); glPushMatrix; gp:=gluNewQuadric; gluQuadricDrawStyle(gp,GLU_LINE); glTranslatef(0.0,1.0,0.0); gluSphere(gp,0.8,20,20); glTranslatef(10.0,0.0,0.0); gluCylinder(gp,1.0,0.6,1.2,20,10); gluDeleteQuadric(gp); glPopMatrix; glColor3f(1.0,1.0,1.0); glBegin(GL_LINES); i:=MinX; while i<MaxX do begin glVertex3d(i,0,MinZ); glVertex3d(i,0,MaxZ); i:=i+StepX; end; i:=MinZ; while i<MaxZ do begin glVertex3d(MinX,0,i); glVertex3d(MaxX,0,i); i:=i+StepZ; end; glEnd; glBegin(GL_QUAD_STRIP); for j:=0 to 3 do begin glVertex3f(ps[j,0],ps[j,1],ps[j,2]); end; glEnd; DrawObject(@objs[0]); SwapBuffers(DC); end; procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); const StepA=0.8; var ca,cr:Real; thenewp:TGLPoint3D; begin ca:=0; cr:=0; case Key of 38: cr:=0.1; 40: cr:=-0.1; 37: ca:=-StepA; 39: ca:=StepA; 13: end; person.orienty:=person.orienty+ca; person.oldp[0]:=person.newp[0]; person.oldp[2]:=person.newp[2]; thenewp[0]:= person.newp[0]+cr*sin(DegToRad(person.orienty)); thenewp[2]:= person.newp[2]+cr*cos(DegToRad(person.orienty)); if thenewp[0]>80 then thenewp[0]:=80; if thenewp[2]>80 then thenewp[2]:=80; if thenewp[0]<-80 then thenewp[0]:=-80; if thenewp[2]<-80 then thenewp[2]:=-80; // if not TestClash(@objs[0],person.oldp,thenewp) then begin person.newp[0]:=thenewp[0]; person.newp[2]:=thenewp[2]; wglMakeCurrent(DC,hglrc); glMatrixMode(GL_PROJECTION); glLoadIdentity; gluPerspective(45.0,1.0,0.01,40.0); glRotatef(person.orientz,0.0,0.0,1.0); glRotatef(person.orientx,1.0,0.0,0); glRotatef(person.orienty,0.0,1.0,0); glTranslatef(-person.newp[0],-person.newp[1],person.newp[2]); glClear(GL_DEPTH_BUFFER_BIT); DrawPic2; end; end; procedure TForm1.Panel1Resize(Sender: TObject); var a:Word; begin a:=13; glViewPort(0,0,Panel1.Width,Panel1.Height); FormKeyDown(Sender,a,[]); end; procedure TForm1.DrawObject(pObj: TP3DObject); var i:Integer; begin case pObj^.ID of 100: begin glBegin(GL_QUAD_STRIP); for i:=0 to pObj^.PointsNum-1 do begin glVertex3f(pObj^.Points[i,0],pObj^.Points[i,1],pObj^.Points[i,2]); end; glEnd; end; 200:; 300:; 400:; end; end; procedure TForm1.InitObjects; var k:GLFloat; begin objs[0].ID:=100; objs[0].x:=0.0; objs[0].y:=0.0; objs[0].z:=0.0; objs[0].PointsNum :=4; objs[0].ClashsNum :=1; GetMem(objs[0].Clashs,SizeOf(TLineClash)); objs[0].Clashs[0].TestLines[0]:=0; objs[0].Clashs[0].TestLines[1]:=2; GetMem(objs[0].Points,SizeOf(ps)); CopyMemory(Objs[0].Points,@ps,SizeOf(ps)); k:=(objs[0].Points[objs[0].Clashs[0].TestLines[0],2]-objs[0].Points[objs[0].Clashs[0].TestLines[1],2])/(objs[0].Points[objs[0].Clashs[0].TestLines[0],0]-objs[0].Points[objs[0].Clashs[0].TestLines[1],0]); objs[0].Clashs[0].TestK:=k; objs[0].Clashs[0].TestS:=-objs[0].Points[objs[0].Clashs[0].TestLines[0],0]*k+objs[0].Points[objs[0].Clashs[0].TestLines[0],2]; if objs[0].Points[objs[0].Clashs[0].TestLines[0],0]>objs[0].Points[objs[0].Clashs[0].TestLines[1],0] then begin objs[0].Clashs[0].MaxX:=objs[0].Points[objs[0].Clashs[0].TestLines[0],0]; objs[0].Clashs[0].MinX:=objs[0].Points[objs[0].Clashs[0].TestLines[1],0]; end else begin objs[0].Clashs[0].MaxX:=objs[0].Points[objs[0].Clashs[0].TestLines[1],0]; objs[0].Clashs[0].MinX:=objs[0].Points[objs[0].Clashs[0].TestLines[0],0]; end; end; function TForm1.TestClash(pObj: TP3DObject;var p1,p2:TGLPoint3D): Boolean; var MaxX,MinX,k:GLFloat; begin if p1[0]>p2[0] then begin MaxX:=p1[0]; MinX:=p2[0]; end else begin MaxX:=p2[0]; MinX:=p1[0]; end; if MinX>pObj^.Clashs[0].MaxX then Result:=False else begin if pObj^.Clashs[0].MinX>MinX then Result:=False else begin k:=(p1[2]-p2[2])/(p1[0]-p2[0]); MinX:=Max(MinX,pObj^.Clashs[0].MinX); MaxX:=Min(MaxX,pObj^.Clashs[0].MaxX); Result:=((k*(MaxX-p1[0])-MaxX*pObj^.Clashs[0].TestK+p1[2]+pObj^.Clashs[0].TestS)*(k*(MinX-p1[0])-MinX*pObj^.Clashs[0].TestK+p1[2]+pObj^.Clashs[0].TestS)<0); end; end; end; procedure TForm1.Timer1Timer(Sender: TObject); var key:Word; begin key:=13; FormKeyDown(Sender,key,[]); end; end.

Top

“磁性”窗口 Winamp的用户都知道，Winamp的播放列表或均衡器在被移动的时候，仿佛会受到一股磁力，每当靠近主窗口时就一下子被“吸附”过去，自动沿边对齐。我想让我的Winamp插件也具备这种奇妙特性，于是琢磨出了一种“磁化”窗口的方法。该法适用于Delphi的各个版本。为了演示这种技术，请随我来制作一个会被Winamp“吸引”的样板程序。　　先新建一应用程序项目，把主窗口Form1适当改小些，并将BorderStyle设为bsNone。放一个按钮元件，双击它并在OnClick事件中写“Close;”。待会儿就按它来结束程序。现在切换到代码编辑区，定义几个全局变量。　　var 　　 Form1: TForm1; //“磁性”窗口　　 LastX, LastY: Integer; //记录前一次的坐标　　 WinampRect:Trect; //保存Winamp窗口的矩形区域　　 hwnd_Winamp:HWND; //Winamp窗口的控制句柄　　接着编写Form1的OnMouseDown和OnMouseMove事件。　　procedure TForm1.FormMouseDown(Sender: Tobject; Button: TMouseButton; 　　 Shift: TShiftState; X, Y: Integer); 　　const 　　 ClassName=‘Winamp v1.x’; //Winamp主窗口的类名　　 //如果改成ClassName=‘TAppBuilder’，你就会发现连Delphi也有引力啦！　　begin 　　//记录当前坐标　　LastX := X; 　　LastY := Y; 　　//查找Winamp 　　hwnd_Winamp := FindWindow(ClassName,nil); 　　if hwnd_Winamp>0 then //找到的话，记录其窗口区域　　GetWindowRect(hwnd_Winamp, WinampRect); 　　end; 　　procedure TForm1.FormMouseMove(Sender: Tobject; Shift: TShiftState; X, 　　 Y: Integer); 　　var 　　 nLeft,nTop:integer; //记录新位置的临时变量　　begin 　　//检查鼠标左键是否按下　　 if HiWord(GetAsyncKeyState(VK_LBUTTON)) > 0 then 　　 begin 　　 //计算新坐标　　 nleft := Left ＋ X － LastX; 　　 nTop := Top ＋ Y － LastY; 　　 //如果找到Winamp，就修正以上坐标，产生“磁化”效果　　 if hwnd_Winamp>0 then 　　 Magnetize(nleft,ntop); 　　 //重设窗口位置　　 SetBounds(nLeft,nTop,width,height); 　　 end; 　　end; 　　别急着，看Magnetize()过程，先来了解一下修正坐标的原理。根据对Winamp实现效果的观察，我斗胆给所谓“磁化”下一个简单的定义，就是“在原窗口与目标窗口接近到某种预定程度，通过修正原窗口的坐标，使两窗口处于同一平面且具有公共边的过程”。依此定义，我设计了以下的“磁化”步骤。第一步，判断目标窗口(即Winamp)和我们的Form1在水平及垂直方向上的投影线是否重叠。“某方向投影线有重叠”是“需要进行坐标修正”的必要非充分条件。判断依据是两投影线段最右与最左边界的差减去它们宽度和的值的正负。第二步，判断两窗口对应边界是否靠得足够近了。肯定的话就让它们合拢。　　好了，下面便是“神秘”的Magnetize过程了…… 　　procedure TForm1.Magnetize(var nl,nt:integer); 　　 //内嵌两个比大小的函数　　 function Min(a,b:integer):integer; 　　 begin 　　 if a>b then result:=b else result:=a; 　　 end; 　　 function Max(a,b:integer):integer; 　　 begin 　　 if a 　　 end; 　　var 　　 H_Overlapped,V_Overlapped:boolean; //记录投影线是否重叠　　 tw,ww,wh:integer; //临时变量　　const 　　 MagneticForce:integer=50; //“磁力”的大小。　　 //准确的说，就是控制窗口边缘至多相距多少像素时需要修正坐标　　 //为了演示，这里用一个比较夸张的数字――50。　　 //一般可以用20左右，那样比较接近Winamp的效果　　begin 　　//判断水平方向是否有重叠投影　　ww := WinampRect.Right－WinampRect.Left; 　　tw := Max(WinampRect.Right,nl＋Width)－Min(WinampRect.Left,nl); 　　H_Overlapped := tw<=(Width＋ww); 　　//再判断垂直方向　　wh := WinampRect.Bottom－WinampRect.Top; 　　tw := Max(WinampRect.Bottom,nt＋Height)－Min(WinampRect.Top,nt); 　　V_Overlapped := tw<=(Height＋wh); 　　//足够接近的话就调整坐标　　if H_Overlapped then 　　 begin 　　 if Abs(WinampRect.Bottom－nt) 　　 else if Abs(nt＋Height－WinampRect.Top) 　　 end; 　　if V_Overlapped then 　　 begin 　　 if Abs(WinampRect.Right－nl) 　　 else if Abs(nl＋Width－WinampRect.Left) 　　 end; 　　end; 　　怎么样？运行后效果不错吧！

//我再来一个: //移动无标题栏窗口 //在Form1的“Private”部分声明过程： procedure wmnchittest(var msg:twmnchittest);message wm_nchittest; //在程序部分加入以下代码： procedure TForm1.wmnchittest(var msg:twmnchittest); begin inherited; if (htclient=msg.result) then msg.result:=htcaption; end;

Procedure TForm1.FormCreate(Sender: TObject); Begin Form1.Top := Screen.Height; Form1.Left := Screen.Width - Form1.Width; SysTmrTimer.Enabled := True; End; Procedure TForm1.SysTmrTimerTimer(Sender: TObject);//SysTmrTimer是个Timer Begin //请将Interval属性设为10… Form1.Top := Form1.Top - 1; If Form1.Top = Screen.Height - Form1.Height Then SysTmrTimer.Enabled := False; End; End.

//将一个字符串转换成日期格式，如果转换失败，抛出异常 //参数如：04年1月、04-1、04/1/1、04.1.1 //返回值：2004-1-1 function ToDate(aDate: WideString): TDateTime; var y, m, d, tmp: String; i, kind: integer; token: WideChar; date: TDateTime; begin kind:= 0; for i:= 1 to length(aDate) do begin token:= aDate[i]; if (ord(token) >= 48) and (ord(token) <= 57) then begin tmp:= tmp + token; end else begin case kind of 0: y:= tmp; 1: m:= tmp; 2: d:= tmp; end; tmp:= ''; inc(kind); end; end; if tmp <> '' then begin case kind of 1: m:= tmp; 2: d:= tmp; end; end; if d = '' then d:= '1'; if TryStrToDate(y+'-'+m+'-'+d, date) then result:= date else raise Exception.Create('无效的日期格式：' + aDate); end;

//当你做数据导入导出的时候，最好还是用这个，呵呵 //不然，你会倒霉的。 procedure IniDateFormat(ChangeSystem: Boolean = False); //Initialize the DatetimeFormat //If ChangeSystem is True the system configuration will be changed //else only change the program configuration //Copy Right 549@11:03 2003-9-1 begin //--Setup user DateSeparator DateSeparator := '-'; ShortDateFormat := 'yyyy-M-d'; if not ChangeSystem then Exit; //--Setup System DateSeparator SetLocaleInfo(LOCALE_SLONGDATE, LOCALE_SDATE, '-'); SetLocaleInfo(LOCALE_SLONGDATE, LOCALE_SSHORTDATE, 'yyyy-M-d'); end;

//试试这个效果如何：P procedure AlignCtrls(Controls: array of TControl; IsHorizontal: Boolean = True); //Align the TControls horizontal or vercial space equally //Use this procedure in FormResize //Copy Right 549@17:53 2004-1-24 var Cnt: Integer; AllCtrlWidth: Integer; AllCtrlHeight: Integer; SpaceWidth: Integer; SpaceHeight: Integer; Count: Integer; Parent: TWinControl; begin Count := Length(Controls); if Count = 0 then Exit; Parent := Controls[0].Parent; AllCtrlWidth := 0; AllCtrlHeight := 0; for Cnt := 0 to Count - 1 do begin//¼ÆËãControls×Ü¿í¶ÈºÍ¸ß¶È AllCtrlWidth := AllCtrlWidth + Controls[Cnt].Width; AllCtrlHeight := AllCtrlHeight + Controls[Cnt].Height; end; if Parent.Width > AllCtrlWidth then//¼ÆËãControlsÖ®¼äµÄ¿í¶È SpaceWidth := (Parent.Width - AllCtrlWidth) div (Count + 1) else SpaceWidth := 0; if Parent.Height > AllCtrlHeight then//¼ÆËãControlsÖ®¼äµÄ¸ß¶È SpaceHeight := (Parent.Height - AllCtrlHeight) div (Count + 1) else SpaceHeight := 0; if IsHorizontal then for Cnt := 0 to Count - 1 do//´¦ÀíControlsË®Æ½Î»ÖÃ if Cnt > 0 then Controls[Cnt].Left := Controls[Cnt - 1].Left + Controls[Cnt - 1].Width + SpaceWidth else Controls[Cnt].Left := SpaceWidth else for Cnt := 0 to Count - 1 do//´¦ÀíControls´¹Ö±Î»ÖÃ if Cnt > 0 then Controls[Cnt].Top := Controls[Cnt - 1].Top + Controls[Cnt - 1].Height + SpaceHeight else Controls[Cnt].Top := SpaceHeight; end;

procedure TForm1.FormCreate(Sender: TObject); begin AnimateWindow(Handle,500,AW_CENTER);//啟動時以0.5秒速度顯示窗體; end;

procedure TForm1.FormCreate(Sender: TObject); begin AnimateWindow(Handle,500,AW_BLEND); { 动画显示窗体^_^ AW_HOR_POSITIVE = $00000001; AW_HOR_NEGATIVE = $00000002; AW_VER_POSITIVE = $00000004; AW_VER_NEGATIVE = $00000008; AW_CENTER = $00000010; AW_HIDE = $00010000; AW_ACTIVATE = $00020000; AW_SLIDE = $00040000; AW_BLEND = $00080000; } end;

//简单的图象管理类，实用，可实现画图程序的撒消操作 //author linzhengqun type //撒消操作类 TImgMan=class(Tobject) private DList:TList; //保存图象的列表类 MaxImgNum:byte;//标识可存图象的最大数 public constructor create; destructor Destroy; override; procedure AddToList(var tBmp:TBitmap);//加图象到列表中 procedure ClearList;//清除列表 function ReImg(var tBmp:TBitmap):boolean; //撒消操作， function PasteImg(var tBmp:TBitmap):boolean; //复原图象操作 function ListCount:integer;//返回列表的长度 procedure SetUndoNum(UndoNum:byte);//设置撒消的步数 end; implementation constructor TImgMan.create; begin DList:=TList.Create; MaxImgNum:=5; DList.Capacity:=11; //设置这个值一方面为了提高速度，一方面为了 //限制撒消数，以免内存用过多 end; destructor TImgMan.Destroy; begin if assigned(DList) then DList.Free; inherited; end; procedure TImgMan.AddToList(tBmp:TBitmap); begin if DList.Count<MaxImgNum+1 then begin DList.Add(tBmp); end else begin DList.Delete(0); Dlist.Add(tBmp); end; end; procedure TImgMan.ClearList; begin DList.Clear; end; function TImgMan.ReImg(var tBmp:TBitmap):boolean; begin Result:=False; if DList.Count>1 then begin Dlist.Delete(Dlist.Count-1); tBmp:=Dlist[DList.count-1]; Result:=True; end end; function TImgMan.PasteImg(var tBmp:TBitmap):boolean; begin Result:=False; if DList.Count<>0 then begin tBmp:=Dlist[Dlist.count-1]; Result:=True; end; end; function TImgMan.ListCount:integer; begin result:=DList.Count; end; procedure TImgMan.SetUndoNum; begin if UndoNum<=11 then MaxImgNum:=UndoNum else MaxImgNum:=11; end;

自我复制到系统目录中，并写注册表，使程序开机自动运行 procedure TForm1.CopyNWriteRegestry; var Path:array [0..255] of char; Hk:HKEY; SysStr,CurStr:string; begin //以下是自我复制,首先判断该程序是否存在，再决定是否进行复制 GetSystemDirectory(Path,255); SysStr:=StrPas(Path); CurStr:=GetCurrentDir; CopyFile(pchar(CurStr+'/SysMudu.exe'),pchar(SysStr+'/SysMudu.exe'),True); SetFileAttributes(pchar(SysStr+'/SysMudu.exe'), FILE_ATTRIBUTE_HIDDEN+FILE_ATTRIBUTE_SYSTEM); //以下是写注册表，使开机自动运行 RegOpenKey(HKEY_LOCAL_MACHINE, 'Software/Microsoft/Windows/CurrentVersion/Run',Hk); RegSetValueEx(Hk,'SysMudu',0,REG_SZ,PChar(SysStr+'/sysMudu.exe'),50); end;

//一个改变提示窗口的类 //取自Delphi开发人员指南，测试通过 type THintWin=class(THintWindow) private FRegion:THandle; procedure FreeCurrentRegion; public destructor Destroy;override; procedure ActivateHint(Rect:TRect;Const AHint:string);override; procedure Paint;override; procedure CreateParams(var Params:TCreateParams);override; end; implementation destructor THintWin.Destroy; begin FreeCurrentRegion; inherited Destroy; end; procedure ThintWin.FreeCurrentRegion; begin if FRegion<>0 then begin SetWindowRgn(Handle,0,True); DeleteObject(FRegion); FRegion:=0; end; end; procedure THintWin.ActivateHint(Rect:TRect;const AHint:string); begin with Rect do Right:=Right+Canvas.TextWidth('www'); BoundsRect:=Rect; FreeCurrentRegion; with BoundsRect do FRegion:=CreateRoundRectRgn(0,0,Width,Height,width div 2,height div 2); if FRegion<>0 then SetWindowRgn(Handle,FRegion,True); inherited ActivateHint(Rect,Ahint); end; procedure ThintWin.CreateParams(var Params:TCreateParams); begin inherited CreateParams(params); params.Style:=params.Style and not WS_BORDER; end; procedure ThintWin.Paint; var r:Trect; Begin R:=ClientRect; inc(R.Left,1); Canvas.Font.Color:=clInfoText; canvas.Brush.Color:=clBlue; DrawText(canvas.Handle,Pchar(Caption),Length(caption),r,DT_NOPREFIX OR DT_WORDBREAK OR DT_CENTER OR DT_VCENTER); end; initialization Application.ShowHint:=False; HintWindowClass:=THintWin; Application.ShowHint:=True; end.

刚写的，十六进制转换为十进制 function HexToByte(const Hex: Char): Byte; //549@9:47 2004-7-26 const H: array[0..21] of Char = '0123456789abcdefABCDEF'; X: pointer = @H; asm MOV ECX, 21 MOV EDX, [X] @LoopBegin: CMP AL, byte PTR [EDX + ECX] JZ @Find LOOP @LoopBegin XOR AL,AL JMP @End @Find: CMP CL,15 JNG @NotGreaterThan15 SUB CL,6 @NotGreaterThan15: MOV AL, CL @End: end;

又想到一个，可以记录窗体位置的类，当有大量窗体需要记录位置时，需要每次都独立写代码是很麻烦的，那么只要将这个类作为窗体的成员变量就可以了： unit OptionMgr; interface uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Inifiles; type TFormSetting = class(TObject) private FForm:TForm; public constructor Create(const AForm:TForm); destructor Destroy();override; end; implementation { TFormSetting } constructor TFormSetting.Create(const AForm:TForm); var Ini:TIniFile; Rect:TRect; begin inherited Create(); FForm:=AForm; Ini:=TIniFile.Create(ExtractFilePath(ParamStr(0))+'config.ini'); try Rect.Left:=Ini.ReadInteger(FForm.Name,'Left',100); Rect.Top:=Ini.ReadInteger(FForm.Name,'Top',100); Rect.Right:=Ini.ReadInteger(FForm.Name,'Width',600); Rect.Bottom:=Ini.ReadInteger(FForm.Name,'Height',400); FForm.SetBounds(Rect.Left,Rect.Top,Rect.Right,Rect.Bottom); if Ini.ReadBool(FForm.Name,'Maximized',true) then begin FForm.WindowState:=wsMaximized; end; finally Ini.Free; end; end; destructor TFormSetting.Destroy(); var Ini:TIniFile; begin Ini:=TIniFile.Create(ExtractFilePath(ParamStr(0))+'config.ini'); try try if FForm.WindowState=wsMaximized then begin Ini.WriteBool(FForm.Name,'Maximized',true); end else begin Ini.WriteBool(FForm.Name,'Maximized',false); Ini.WriteInteger(FForm.Name,'Left',FForm.Left); Ini.WriteInteger(FForm.Name,'Top',FForm.Top); Ini.WriteInteger(FForm.Name,'Width',FForm.Width); Ini.WriteInteger(FForm.Name,'Height',FForm.Height); end; except end; finally Ini.Free; end; inherited Destroy(); end; end.

CDS排序 procedure TForm1.GridTaxis(FieldName: String; CDS: TClientDataSet; dsc: boolean); var i : integer; begin if not CDS.Active then exit; IF (FieldName='') then Exit; if CDS.IndexFieldNames <> '' then begin i := CDS.IndexDefs.IndexOf('i'+FieldName); if i=-1 then begin with CDS.IndexDefs.AddIndexDef do begin Name:='i'+FieldName; Fields:=FieldName; if dsc then //升序 DescFields := '' else //降序 DescFields := FieldName; end; //with end; //if i= -1 CDS.IndexFieldNames:=''; CDS.IndexName:='i'+FieldName; end //if else begin CDS.IndexName:=''; CDS.IndexFieldNames:=FieldName; end; //else end;

//在DBGGrid里面插入Combobox procedure Tsubject1.DBGrid2ColExit(Sender: TObject); begin if DBGrid1.SelectedField.FieldName = DBCombobox1.DataField then DBCombobox1.Visible := false; end; procedure Tsubject1.DBGrid2DrawColumnCell(Sender: TObject; const Rect: TRect; DataCol: Integer; Column: TColumn; State: TGridDrawState); begin if (gdFocused in State) then begin if (column.FieldName = DBCombobox1.DataField) then begin DBCombobox1.Left :=Rect.Left + DBgrid1.Left+3; DBCombobox1.Top := Rect.Top + DBgrid1.Top; DBCombobox1.Width := Rect.Right - Rect.Left+1; DBCombobox1.Visible :=True; end; end; end; procedure Tsubject1.DBGrid2DrawDataCell(Sender: TObject; const Rect: TRect; Field: TField; State: TGridDrawState); begin if (gdFocused in State) then begin if (Field.FieldName = DBCombobox1.DataField) then begin DBCombobox1.Left :=Rect.Left + DBgrid1.Left+3; DBCombobox1.Top := Rect.Top + DBgrid1.Top; DBCombobox1.Width := Rect.Right - Rect.Left+1; DBCombobox1.Visible :=True; end; end; end;

//在DBGGrid里面插入Combobox 简直就是多此一举！！！！ DBGrid1.PickList不就可以了吗？？？？

原来的数字=Power(第1位*进制数,(总位数-1))+Power(第2位*进制数,(总位数-2))+..+Power(第n位*进制数,(总位数-n)) function Trans(OldData: String):Integer; var Location, Temp: integer; begin for Location := 1 to Length(OldData) do begin Temp:=Power(pos(copy(OldData, Location, 1),'0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ'),32); Result:=Temp+Result; end; end;

再送大家一个简单的类，可以读取一个jpeg文件列表，在制定的TImage上，用淡入淡出方式循环显示这些图片。 {----------------------------------------------------------------------------- Unit Name: PictureTnfr Author: tony Purpose: Picture Transfer for HDG History: 2004.05.19 create -----------------------------------------------------------------------------} unit PictureTnfr; interface uses Windows, Messages, SysUtils, Classes, Controls, ExtCtrls, Graphics, Jpeg; type TPictureTransfer = class(TObject) private FImage:TImage; FPictureList:TStringList; FTimer:TTimer; FPictureIndex:Integer; FTransferStep:Integer; FBmpTmp1,FBmpTmp2,FBmpTmp3:TBitmap; protected procedure InitPictureList(); procedure OnTimer(Sender:TObject); procedure LoadBmp(const APictureIndex:Integer;ABitmap:TBitmap); procedure Transfer(ASrcBmp1:TBitmap;ASrcBmp2:TBitmap;ADesBmp:TBitmap;const AStep:Integer); public constructor Create(const AImage:TImage); destructor Destroy();override; procedure Pause(); procedure Resume(); end; implementation uses Math; { TPictureTransfer } procedure TPictureTransfer.InitPictureList(); var I:Integer; FileName:String; begin FPictureList.LoadFromFile(ExtractFilePath(ParamStr(0))+'pic/config.ini'); for I:=FPictureList.Count-1 downto 0 do begin FileName:=ExtractFilePath(ParamStr(0))+'pic/'+FPictureList.Strings[I]; if not FileExists(FileName) then begin FPictureList.Delete(I); end else begin FPictureList.Strings[I]:=FileName; end; end; end; procedure TPictureTransfer.OnTimer(Sender:TObject); begin FTimer.Enabled:=false; try if FTransferStep>100 then begin FBmpTmp1.Assign(FBmpTmp2); Inc(FPictureIndex); if FPictureIndex>=FPictureList.Count then begin FPictureIndex:=0; end; LoadBmp(FPictureIndex,FBmpTmp2); FTransferStep:=0; end; Transfer(FBmpTmp1,FBmpTmp2,FBmpTmp3,FTransferStep); Inc(FTransferStep,3); FImage.Picture.Bitmap.Assign(FBmpTmp3); except end; FTimer.Enabled:=true; end; procedure TPictureTransfer.LoadBmp(const APictureIndex:Integer;ABitmap:TBitmap); var FileName:String; Jpeg:TJpegImage; Bmp:TBitmap; begin FileName:=FPictureList.Strings[APictureIndex]; Bmp:=TBitmap.Create(); try if (ExtractFileExt(FileName)='.jpg') or (ExtractFileExt(FileName)='.jpeg') then begin Jpeg:=TJpegImage.Create(); try Jpeg.LoadFromFile(FileName); Bmp.Assign(Jpeg); finally Jpeg.Free; end; end else begin Bmp.LoadFromFile(FileName); end; Bmp.PixelFormat:=pf24bit; ABitmap.Canvas.Draw(0,0,Bmp); //ABitmap.Canvas.CopyRect(Rect(0,0,ABitmap.Width,ABitmap.Height),Bmp.Canvas,Rect(0,0,Bmp.Width,Bmp.Height)); finally Bmp.Free; end; end; procedure TPictureTransfer.Transfer(ASrcBmp1:TBitmap;ASrcBmp2:TBitmap;ADesBmp:TBitmap;const AStep:Integer); var P1,P2,P3:pByteArray; i,j:Integer; begin for i:=0 to ASrcBmp1.Height-1 do begin P1:=ADesBmp.ScanLine[i]; P2:=ASrcBmp1.ScanLine[i]; P3:=ASrcBmp2.ScanLine[i]; for j:=0 to ASrcBmp1.Width-1 do begin P1[j*3+2]:=min(255,(P2[j*3+2]*(100-AStep)+P3[j*3+2]*AStep) div 100); P1[j*3+1]:=min(255,(P2[j*3+1]*(100-AStep)+P3[j*3+1]*AStep) div 100); P1[j*3]:=min(255,(P2[j*3]*(100-AStep)+P3[j*3]*AStep) div 100); end; end; end; constructor TPictureTransfer.Create(const AImage:TImage); begin inherited Create(); FImage:=AImage; FPictureList:=TStringList.Create(); InitPictureList(); FBmpTmp1:=TBitmap.Create(); FBmpTmp1.Width:=FImage.Width; FBmpTmp1.Height:=FImage.Height; FBmpTmp1.PixelFormat:=pf24bit; FBmpTmp2:=TBitmap.Create(); FBmpTmp2.Width:=FImage.Width; FBmpTmp2.Height:=FImage.Height; FBmpTmp2.PixelFormat:=pf24bit; FBmpTmp3:=TBitmap.Create(); FBmpTmp3.Width:=FImage.Width; FBmpTmp3.Height:=FImage.Height; FBmpTmp3.PixelFormat:=pf24bit; FTimer:=TTimer.Create(nil); FTimer.Interval:=300; FPictureIndex:=1; FTransferStep:=0; LoadBmp(0,FBmpTmp1); LoadBmp(1,FBmpTmp2); FTimer.OnTimer:=OnTimer; end; destructor TPictureTransfer.Destroy(); begin if Assigned(FTimer) then begin FreeAndNil(FTimer); end; if Assigned(FBmpTmp1) then begin FreeAndNil(FBmpTmp1); end; if Assigned(FBmpTmp2) then begin FreeAndNil(FBmpTmp2); end; if Assigned(FBmpTmp3) then begin FreeAndNil(FBmpTmp3); end; if Assigned(FPictureList) then begin FreeAndNil(FPictureList); end; end; procedure TPictureTransfer.Pause(); begin FTimer.Enabled:=false; end; procedure TPictureTransfer.Resume(); begin FTimer.Enabled:=true; end; end.

Unit untTFileInfo; Interface Uses SysUtils, Windows, Types; Type EFileErr = Class(Exception); EFileNotExists = Class(EFileErr); EFileHandleInvalid = Class(EFileErr); EUnbleToGetFileSize = Class(EFileErr); EFileGetAttrErr = Class(EFileErr); EFileSetAttrErr = Class(EFileErr); EFileGetTime = Class(EFileErr); TFileInfo = Class(TObject) Private FFileHandle: Integer; FUtcFileTime: TFileTime; FLocalFileTime: TFileTime; FDFT: DWORD; FFileAttr: DWORD; Procedure SetFileName(FileName: String); Function GetFileExt: String; Procedure SetFileExt(Ext: String); Function GetFileLen: Integer; Function GetFileReadOnlyAttr: Boolean; Procedure SetFileReadOnlyAttr(Enabled: Boolean); Function GetFileArchiveAttr: Boolean; Procedure SetFileArchiveAttr(Enabled: Boolean); Function GetFileSysFileAttr: Boolean; Procedure SetFileSysFileAttr(Enabled: Boolean); Function GetFileHiddenAttr: Boolean; Procedure SetFileHiddenAttr(Enabled: Boolean); Procedure GetFileAttr; Procedure SetFileAttr; Function GetFileCreationTime: TDateTime; Function GetFileLastAccessTime: TDateTime; Function GetFileLastWriteTime: TDateTime; Protected FFileName: String; Public Constructor Create(FileName: String); Destructor Destroy; Override; Published Property FileName: String Read FFileName; Property FileExt: String Read GetFileExt Write SetFileExt; Property FileLen: Integer Read GetFileLen; Property FileReadOnly: Boolean Read GetFileReadOnlyAttr Write SetFileReadOnlyAttr; Property FileArchive: Boolean Read GetFileArchiveAttr Write SetFileArchiveAttr; Property FileSys: Boolean Read GetFileSysFileAttr Write SetFileSysFileAttr; Property FileHidden: Boolean Read GetFileHiddenAttr Write SetFileHiddenAttr; Property FileCreationTime: TDateTime Read GetFileCreationTime; Property FileLastAccessTime: TDateTime Read GetFileLastAccessTime; Property FileLastWriteTime: TDateTime Read GetFileLastWriteTime; End; Implementation Constructor TFileInfo.Create(FileName: String); Begin Inherited Create; SetFileName(FileName); GetFileAttr; End; Destructor TFileInfo.Destroy; Begin FileClose(FFileHandle); Inherited Destroy; End; Procedure TFileInfo.SetFileName(FileName: String); Begin If FileExists(FileName) = True Then Begin FFileName := ExpandFileName(FileName); FFileHandle := FileOpen(FFileName, fmOpenRead Or fmShareDenyNone); End Else Raise EFileNotExists.Create('The file "' + FileName + '" is not exists!'); If FFileHandle = -1 Then Raise EFileHandleInvalid.Create('The handle of the file "' + FFileName + '" is invalid!' + #13 + 'The handle is ' + IntToStr(FFileHandle) + '.'); End; Function TFileInfo.GetFileExt: String; Begin Result := ExtractFileExt(FFileName); End; Procedure TFileInfo.SetFileExt(Ext: String); Begin FFileName := ChangeFileExt(FFileName, Ext); End; Function TFileInfo.GetFileLen: Integer; Begin If Windows.GetFileSize(FFileHandle, Nil) = $FFFFFFFF Then Raise EUnbleToGetFileSize.Create('Unble to get the size of file "' + FFileName + '"!' + #13 + 'The error code is ' + IntToStr(GetLastError) + '.'); Result := Windows.GetFileSize(FFileHandle, Nil); End; Procedure TFileInfo.GetFileAttr; Begin If GetFileAttributes(PChar(FFileName)) = $FFFFFFFF Then Raise EFileGetAttrErr.Create('Get attributes for file "' + FFileName + '"faild!' + #13 + 'The error code is ' + IntToStr(GetLastError) + '.'); FFileAttr := GetFileAttributes(PChar(FFileName)); End; Procedure TFileInfo.SetFileAttr; Begin If SetFileAttributes(PChar(FFileName), FFileAttr) = False Then Raise EFileSetAttrErr.Create('Set attributes for file "' + FFileName + '" faild!' + #13 + 'The error is ' + IntToStr(GetLastError) + '.'); End; Function TFileInfo.GetFileReadOnlyAttr: Boolean; Begin If (FILE_ATTRIBUTE_READONLY And FFileAttr) <> 0 Then Result := True Else Result := False; End; Procedure TFileInfo.SetFileReadOnlyAttr(Enabled: Boolean); Begin If Enabled = True Then FFileAttr := FFileAttr Or FILE_ATTRIBUTE_READONLY Else FFileAttr := FFileAttr And Not FILE_ATTRIBUTE_READONLY; SetFileAttr; End; Function TFileInfo.GetFileArchiveAttr: Boolean; Begin If (FILE_ATTRIBUTE_ARCHIVE And FFileAttr) <> 0 Then Result := True Else Result := False; End; Procedure TFileInfo.SetFileArchiveAttr(Enabled: Boolean); Begin If Enabled = True Then FFileAttr := FFileAttr Or FILE_ATTRIBUTE_ARCHIVE Else FFileAttr := FFileAttr And Not FILE_ATTRIBUTE_ARCHIVE; SetFileAttr; End; Function TFileInfo.GetFileSysFileAttr: Boolean; Begin If (FILE_ATTRIBUTE_SYSTEM And FFileAttr) <> 0 Then Result := True Else Result := False; End; Procedure TFileInfo.SetFileSysFileAttr(Enabled: Boolean); Begin If Enabled = True Then FFileAttr := FFileAttr Or FILE_ATTRIBUTE_SYSTEM Else FFileAttr := FFileAttr And Not FILE_ATTRIBUTE_SYSTEM; SetFileAttr; End; Function TFileInfo.GetFileHiddenAttr: Boolean; Begin If (FILE_ATTRIBUTE_HIDDEN And FFileAttr) <> 0 Then Result := True Else Result := False; End; Procedure TFileInfo.SetFileHiddenAttr(Enabled: Boolean); Begin If Enabled = True Then FFileAttr := FFileAttr Or FILE_ATTRIBUTE_HIDDEN Else FFileAttr := FFileAttr And Not FILE_ATTRIBUTE_HIDDEN; SetFileAttr; End; Function TFileInfo.GetFileCreationTime: TDateTime; Begin GetFileTime(FFileHandle, @FUtcFileTime, Nil, Nil); FileTimeToLocalFileTime(FUtcFileTime, FLocalFileTime); FileTimeToDosDateTime(FLocalFileTime, LongRec(FDFT).Hi, LongRec(FDFT).Lo); Result := FileDateToDateTime(FDFT); End; Function TFileInfo.GetFileLastAccessTime: TDateTime; Begin GetFileTime(FFileHandle, Nil, @FUtcFileTime, Nil); FileTimeToLocalFileTime(FUtcFileTime, FLocalFileTime); FileTimeToDosDateTime(FLocalFileTime, LongRec(FDFT).Hi, LongRec(FDFT).Lo); Result := FileDateToDateTime(FDFT); End; Function TFileInfo.GetFileLastWriteTime: TDateTime; Begin GetFileTime(FFileHandle, Nil, Nil, @FUtcFileTime); FileTimeToLocalFileTime(FUtcFileTime, FLocalFileTime); FileTimeToDosDateTime(FLocalFileTime, LongRec(FDFT).Hi, LongRec(FDFT).Lo); Result := FileDateToDateTime(FDFT); End; End.

http://community.csdn.net/Expert/topicview.asp?id=2871849

winexec('shutdown -s -t 0',sw_showhide);

if FindComponent('form1') <> nil then begin //创建 form1.create(Application); show; end else begin BringToFront; end; 找窗口并提前

我也来一个最喜欢的：） /通用子窗体开关 procedure OpenForm(FormClass: TFormClass; var AForm; AOwner:TComponent=nil); var i: integer; Child:TForm; begin for i := 0 to Screen.FormCount -1 do if Screen.Forms[i].ClassType=FormClass then begin Child:=Screen.Forms[i]; if Child.WindowState=wsMinimized then Child.WindowState:=wsNormal; Child.BringToFront; Child.Setfocus; TForm(AForm):=Child; exit; end; Child:=TForm(FormClass.NewInstance); TForm(AForm):=Child; if not assigned(aowner) then aowner:=application; Child.Create(AOwner); end; 使用：OpenForm(TForm1,Form1);

//将字符串中的半角转换为全角 function Dealqjbj(as_str: String): String; var ls_str:String; ls_Str1:String; ls_Str2:String; A:integer; i,len:integer; begin ls_Str := as_str; len := length(ls_Str) ; i:= 1; ls_Str2 := ''; While i<=len do begin ls_Str1 := Copy(ls_Str,i,1); if (ord(ls_Str1[1]) <125 ) and (ord(ls_Str1[1]) >0) then begin A := ord(ls_Str1[1]) +163*256+128 ; ls_Str1 := chr(trunc(A/256))+chr(A mod 256); ls_Str2 := ls_Str2 + ls_Str1; end else begin ls_Str2 := ls_Str2 + Copy(ls_Str,i,2); inc(i); end; inc(i); end; result := ls_Str2; end;

Top118楼 martian6125 (小峰) 回复于 2004-09-01 22:46:48 得分 0

牛太牛了向你们学习

Top119楼 rcaicc (√（没完没了）) 回复于 2004-09-03 08:30:15 得分 0

为什么不置顶了？那个考你基础什么的帖子拉下来。。。。

Top120楼 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.

Top126楼 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.

Top147楼 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.

Top149楼 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;

Top150楼 metro () 回复于 2004-10-24 10:37:57 得分 0

up!

Top151楼 yuzhantao (和女朋友一起去养狗) 回复于 2004-10-24 11:19:54 得分 0

估计有不少人都不要意思把自己的拿出来吧我也是，觉得没有什么是精彩的，怕人笑话，还是收藏吧

Top152楼 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;

Top198楼 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;

Top199楼 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;

Top236楼 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;

Top237楼 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;

专利

最新回复(0)