Delphi笔记_H5之家 - 中国HTML5教程资源分享第一站

本人今天把自已以前的一些delphi编程经验进行个小总结，总结完后突有一个这样的想法：如果我把这些总结发给网上的delphi朋友，而他们如果也有些自已的delphi编程小结，也发给我(如果愿意的话),这样大家的进步肯定是很快的。本人email：yesterday97@hotmail.com (1).按下ctrl和其它键之后发生一事件。 procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); begin if (ssCtrl in Shift) and (key =67) then showmessage('keydown Ctrl+C'); end; (2).Dbgrid中用Enter键代替Tab键. procedure TForm1.DBGrid1KeyPress(Sender: TObject; var Key: Char); begin if Key = #13 then if ActiveControl = DBGrid1 then begin TDBGrid(ActiveControl).SelectedIndex := TDBGrid(ActiveControl).SelectedIndex + 1; Key := #0; end; end; (3).Dbgrid中选择多行发生一事件。 procedure TForm1.Button1Click(Sender: TObject); var i:integer; bookmarklist:Tbookmarklist; bookmark:tbookmarkstr; begin bookmark:=adoquery1.Bookmark; bookmarklist:=dbgrid1.SelectedRows; try begin for i:=0 to bookmarklist.Count-1 do begin adoquery1.Bookmark:=bookmarklist[i]; with adoquery1 do begin edit; fieldbyname('mdg').AsString:=edit2.Text; post; end; end; end; finally adoquery1.Bookmark:=bookmark; end; end; (4).Form的一个出现效果。 procedure TForm1.Button1Click(Sender: TObject); var r:thandle; i:integer; begin for i:=1 to trunc(width/1.414) do begin r:=CreateEllipticRgn(trunc(width/2)-i,trunc(height/2)-i,trunc(width/2)+i,trunc(height/2)+i); SetWindowRgn(handle,r,true); Application.ProcessMessages; sleep(1); end; end; (5).用Enter代替Tab在编辑框中移动隹点。 procedure TForm1.FormKeyPress(Sender: TObject; var Key: Char); begin if key=#13 then begin if not (Activecontrol is Tmemo) then begin key:=#0; keybd_event(vk_tab,mapvirtualkey(vk_tab,0),0,0); end; end; end; (6).Progressbar加上色彩。 const {$EXTERNALSYM PBS_MARQUEE} PBS_MARQUEE = 08; var Form1: TForm1; implementation {$R *.dfm} uses CommCtrl; procedure TForm1.Button1Click(Sender: TObject); begin // Set the Background color to teal Progressbar1.Brush.Color := clTeal; // Set bar color to yellow SendMessage(ProgressBar1.Handle, PBM_SETBARCOLOR, 0, clYellow); end; (7).住点移动时编辑框色彩不同。 procedure TForm1.Edit1Enter(Sender: TObject); begin (sender as tedit).Color:=clred; end; procedure TForm1.Edit1Exit(Sender: TObject); begin (sender as tedit).Color:=clwhite; end; (8).备份和恢复 procedure TForm1.Button1Click(Sender: TObject); begin if OpenDialog1.Execute then begin try adoconnection1.Connected:=False; adoconnection1.ConnectionString:='Provider=SQLOLEDB.1;Persist Security Info=False;User ID=sa;Initial Catalog=master;Data Source=FRIEND-YOFZKSCO;'+ 'Use Procedure for Prepare=1;Auto Translate=True;Packet Size=4096;Workstation ID=FRIEND-YOFZKSCO;Use Encryption for Data=False;Tag with column collation when possible=False'; adoconnection1.Connected:=True; with adoQuery1 do begin Close; SQL.Clear; SQL.Add('Backup DataBase sfa to disk ='''+opendialog1.FileName+''''); ExecSQL; end; except ShowMessage('±?·Yê§°ü'); Exit; end; end; Application.MessageBox('1§?2?ú￡?êy?Y±?·Y3é1|','ìáê?',MB_OK + MB_ICONINFORMATION); end; procedure TForm1.Button2Click(Sender: TObject); begin if OpenDialog1.Execute then begin try adoconnection1.Connected:=false; adoconnection1.ConnectionString:='Provider=SQLOLEDB.1;Persist Security Info=False;User ID=sa;Initial Catalog=master;Data Source=FRIEND-YOFZKSCO;'+ 'Use Procedure for Prepare=1;Auto Translate=True;Packet Size=4096;Workstation ID=FRIEND-YOFZKSCO;Use Encryption for Data=False;Tag with column collation when possible=False'; adoconnection1.Connected:=true; with adoQuery1 do begin Close; SQL.Clear; SQL.Add('Restore DataBase sfa from disk ='''+opendialog1.FileName+''''); ExecSQL; end; except ShowMessage('???′ê§°ü'); Exit; end; end; Application.MessageBox('1§?2?ú￡?êy?Y???′3é1|','ìáê?',MB_OK + MB_ICONINFORMATION); end; 回复人： delphiyesterday(郑康益) ( ) 信誉：31 2003-6-5 14:39:33 得分:0 (9).查找局域网上的sqlserver报务器。 uses Comobj; procedure TForm1.Button1Click(Sender: TObject); var SQLServer:Variant; ServerList:Variant; i,nServers:integer; sRetValue:String; begin SQLServer := CreateOleObject('SQLDMO.Application'); ServerList:= SQLServer.ListAvailableSQLServers; nServers:=ServerList.Count; for i := 1 to nservers do ListBox1.Items.Add(ServerList.Item(i)); SQLServer:=NULL; serverList:=NULL; end; (10).窗体打开时的淡入效果。 procedure TForm1.FormCreate(Sender: TObject); begin AnimateWindow (Handle, 400, AW_CENTER); end; (11).动态创建窗体。 procedure TForm1.Button1Click(Sender: TObject); begin try form2:=Tform2.Create(self); form2.ShowModal; finally form2.Free; end; end; procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction); begin action:=cafree; end; procedure TForm1.FormDestroy(Sender: TObject); begin form1:=nil; end; (12).复制文件。 procedure TForm1.Button1Click(Sender: TObject); begin try copyfileA(pchar('C:\AAA.txt'),pchar('D:\AAA.txt'),false); except showmessage('sfdsdf'); end; end; (13).复制文件夹。 uses shellAPI; procedure TForm1.Button1Click(Sender: TObject); var lpFileOp: TSHFileOpStruct; begin with lpFileOp do begin Wnd:=Self.Handle; wfunc:=FO_COPY; pFrom:=pchar('C:\AAA'); pTo:=pchar('D:\AAA'); fFlags:=FOF_ALLOWUNDO; hNameMappings:=nil; lpszProgressTitle:=nil; fAnyOperationsAborted:=True; end; if SHFileOperation(lpFileOp)<>0 then ShowMessage('删除失败'); end; (14).改变Dbgrid的选定色。 procedure TForm1.DBGrid1DrawDataCell(Sender: TObject; const Rect: TRect; Field: TField; State: TGridDrawState); begin if gdSelected in state then SetBkColor(dbgrid1.canvas.handle,clgreen) else setbkcolor(dbgrid1.canvas.handle,clwhite); dbgrid1.Canvas.TextRect(rect,0,0,field.AsString); dbgrid1.Canvas.Textout(rect.Left,rect.Top,field.AsString); end; (15).检测系统是否已安装了ADO。 uses registry; function Tform1.ADOInstalled:Boolean; var r:TRegistry; s:string; begin r := TRegistry.create; try with r do begin RootKey := HKEY_CLASSES_ROOT; OpenKey( '\ADODB.Connection\CurVer', false ); s := ReadString(''); if s <> '' then Result := True else Result := False; CloseKey; end; finally r.free; end; end; procedure TForm1.Button1Click(Sender: TObject); begin if ADOInstalled then showmessage('this computer has installed ADO'); end; (16).取利主机的ip地址。 uses winsock; procedure TForm1.Button1Click(Sender: TObject); var IP:string; IPstr:String; buffer:array[1..32] of char; i:integer; WSData:TWSAdata; Host:PHostEnt; begin if WSAstartup(2,WSData)<>0 then begin showmessage('WS2_32.DLL3?ê??ˉê§°ü.'); exit; end; try if GetHostname(@buffer[1],32)<>0 then begin showmessage('??óDμ?μ??÷?ú??.'); exit; end; except showmessage('??óD3é1|·μ???÷?ú??'); exit; end; Host:=GetHostbyname(@buffer[1]); if Host=nil then begin showmessage('IPμ??·?a??.'); exit; end else begin edit2.Text:=Host.h_name; edit3.Text:=chr(host.h_addrtype+64); for i:=1 to 4 do begin IP:=inttostr(ord(host.h_addr^[i-1])); if i<4 then ipstr:=ipstr+IP+'.' else edit1.Text:=ipstr+ip; end; end; WSACleanup; end; (17).取得计算机名。 function tform1.get_name:string; var ComputerName: PChar; size: DWord; begin GetMem(ComputerName,255); size:=255; if GetComputerName(ComputerName,size)=False then result:='' else result:=ComputerName; FreeMem(ComputerName); end; procedure TForm1.Button1Click(Sender: TObject); begin label1.Caption:=get_name; end; Top 回复人： delphiyesterday(郑康益) ( ) 信誉：31 2003-6-5 14:40:54 得分:0 (18).取得硬盘序列号。 function tform1.GetHDSerialNumber: LongInt; {$IFDEF WIN32} var pdw : pDWord; mc, fl : dword; {$ENDIF} begin {$IfDef WIN32} New(pdw); GetVolumeInformation('c:\',nil,0,pdw,mc,fl,nil,0); Result := pdw^; dispose(pdw); {$ELSE} Result := GetWinFlags; {$ENDIF} end; procedure TForm1.Button1Click(Sender: TObject); begin edit1.Text:=inttostr(gethdserialnumber); end; (19).限定光标移动范围。 procedure TForm1.Button1Click(Sender: TObject); var rect1:trect; begin rect1:=button2.BoundsRect; mapwindowpoints(handle,0,rect1,2); clipcursor(@rect1); end; procedure TForm1.Button2Click(Sender: TObject); var screenrect:trect; begin screenrect:=rect(0,0,screen.Width,screen.Height); clipcursor(@screenrect); end; (20).限制edit框只能输入数字。 procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char); begin if not (key in ['0'..'9','.',#8]) then begin key:=#0; Messagebeep(0); end; end; (21).dbgrid中根据任一条件某一格变色。 procedure TForm_main.DBGridEh1DrawColumnCell(Sender: TObject; const Rect: TRect; DataCol: Integer; Column: TColumnEh; State: TGridDrawState); begin if (trim(DataModule1.ADOQuery1.FieldByName('dczt').AsString)='OK') then begin if datacol=6 then begin DbGrideh1.Canvas.Brush.Color:=clGradientActiveCaption; DbGrideh1.DefaultDrawColumnCell(Rect,datacol,column,state); end; end; end; (22).打开word文件。 procedure TfjfsglForm.SpeedButton4Click(Sender: TObject); var MSWord: Variant; str:string; begin if trim(DataModule1.adoquery27.fieldbyname('fjmc').asstring)<>'' then begin str:=trim(DataModule1.ADOQuery27.fieldbyname('fjmc').AsString); MSWord:= CreateOLEObject('Word.Application');// MSWord.Documents.Open('d:\Program Files\Common Files\Sfa\'+str, True);// MSWord.Visible:=1;// str:=''; MSWord.ActiveDocument.Range(0, 0);// MSWord.ActiveDocument.Range.InsertAfter(str);//?úWord?D???ó×?·?'Title' MSWord.ActiveDocument.Range.InsertParagraphAfter; end else showmessage(''); end; (23).word文件传入和传出数据库。 uses IdGlobal; procedure TdjhyForm.SpeedButton2Click(Sender: TObject); var sfilename:string; function BlobContentTostring(const Filename:string):string; begin with Tfilestream.Create(filename,fmopenread) do try setlength(result,size); read(pointer(result)^,size); finally free; end; end; begin if opendialog1.Execute then begin sfilename:=opendialog1.FileName; DataModule1.ADOQuery14.Edit; DataModule1.ADOQuery14.FieldByName('word').AsString:=blobcontenttostring(sfilename); DataModule1.ADOQuery14.Post; end; end; procedure TdjhyForm.SpeedButton1Click(Sender: TObject); var sfilename:string; bs:Tadoblobstream; begin bs:=Tadoblobstream.Create(TBLOBfield(DataModule1.ADOQuery14.FieldByName('word')),bmread); try sfilename:=extractfilepath(application.ExeName)+trim(DataModule1.adoquery14.fieldbyname('hybh').AsString); sfilename:=sfilename+'.'+'doc'; bs.SaveToFile(sfilename); try djhyopenform:=Tdjhyopenform.Create(self); djhyopenform.olecontainer1.CreateObjectFromFile(sfilename,false); djhyopenform.OleContainer1.Iconic:=true; djhyopenform.ShowModal; finally djhyopenform.Free; end; finally bs.free; end; end; (24).中文标题的提示框。 procedure TdjhyForm.SpeedButton5Click(Sender: TObject); begin if Application.MessageBox('', Mb_YesNo + Mb_IconWarning) =Id_yes then DataModule1.ADOQuery14.Delete; end; (25).运行一应用程序文件。 WinExec('HH.EXE D:\Program files\common files\MyshipperCRM e-sales help\MyshipperCRM e-sales help.chm',SW_NORMAL);