DBGrid 应用全书

{***********************************************************************}
{*在 Delphi 语言的数据库编程中，DBGrid 是显示数据的主要手段之一。
{*但是 DBGrid 缺省的外观未免显得单调和缺乏创意。其实，我们完全可
{*以在我们的程序中通过编程来达到美化DBGrid 外观的目的。通过编程，
{*我们可以改变 DBGrid 的表头、网格、网格线的前景色和背景色，以及
{*相关的字体的大小和风格。
{* 转自：jinjazz 落寞刺客
{*DBGrid 应用全书[感谢archonwang]
{*airii的blog上看到的文章,动了动手
{*原文http://www.delphibbs.com/keylife/iblog_show.asp?xid=4091
{***********************************************************************}


1、 {外观}

{======================
 表头、隔行、网格
 ======================}
procedure  TForm1 . DBGridDrawColumnCell_A ( Sender :  TObject ;  const  Rect :  TRect ;
   DataCol :  Integer ;  Column :  TColumn ;  State :  TGridDrawState );
var  i  : integer ;
begin
if  gdSelected  in  State  then  Exit ;
//定义表头的字体和背景颜色：
   for  i  := 0  to  ( Sender  as  TDBGrid ). Columns . Count - 1  do
   begin
     ( Sender  as  TDBGrid ). Columns [ i ]. Title . Font . Name  := '宋体' ;  //字体
     ( Sender  as  TDBGrid ). Columns [ i ]. Title . Font . Size  := 9 ;  //字体大小
     ( Sender  as  TDBGrid ). Columns [ i ]. Title . Font . Color  := $000000ff ;  //字体颜色(红色)
     ( Sender  as  TDBGrid ). Columns [ i ]. Title . Color  := $0000ff00 ;  //背景色(绿色)
   end ;
//隔行改变网格背景色：
if  ( Sender  as  TDBGrid ). DataSource . DataSet . RecNo  mod  2  =  0  then
     ( Sender  as  TDBGrid ). Canvas . Brush . Color  :=  clInfoBk  //定义背景颜色
else
     ( Sender  as  TDBGrid ). Canvas . Brush . Color  :=  RGB ( 191 ,  255 ,  223 );  //定义背景颜色
//定义网格线的颜色：
     TDBGrid ( sender ). DefaultDrawColumnCell ( Rect , DataCol , Column , State );
with  ( Sender  as  TDBGrid ). Canvas  do  //画 cell 的边框
begin
     Pen . Color  :=  $00ff0000 ;  //定义画笔颜色(蓝色)
     MoveTo ( Rect . Left ,  Rect . Bottom );  //画笔定位
     LineTo ( Rect . Right ,  Rect . Bottom );  //画蓝色的横线
     Pen . Color  :=  $0000ff00 ;  //定义画笔颜色(绿色)
     MoveTo ( Rect . Right ,  Rect . Top );  //画笔定位
     LineTo ( Rect . Right ,  Rect . Bottom );  //画绿色的竖线
end ;
end ;


{======================
  焦点单元变色
  =====================}
procedure  TForm1 . DBGridDrawColumnCell_B ( Sender :  TObject ;  const  Rect :  TRect ;
   DataCol :  Integer ;  Column :  TColumn ;  State :  TGridDrawState );
begin
   if  (( State  =  [ gdSelected ])  or  ( State =[ gdSelected , gdFocused ]))  then
     TDBGrid ( sender ). Canvas . Brush . color := clRed ;  //当前行以红色显示，其它行使用背景的浅绿色
     TDBGrid ( sender ). Canvas . pen . mode := pmmask ;
     TDBGrid ( sender ). DefaultDrawColumnCell  ( Rect , DataCol , Column , State );
end ;

{====================
  单元字体变色
 ===================}
procedure  TForm1 . DBGridDrawColumnCell_C ( Sender :  TObject ;  const  Rect :  TRect ;
   DataCol :  Integer ;  Column :  TColumn ;  State :  TGridDrawState );
begin
if  copy ( TDbgrid ( sender ). DataSource . DataSet . fieldbyname ( column . Title . Caption ). AsString , 1 , 1 )= 'A'  then
   TDBGrid ( sender ). Canvas . Font . Color  :=  clRed
else
   if  (( State =[ gdSelected , gdFocused ]))  then
    TDBGrid ( sender ). Canvas . Font . Color  :=  clWhite
    else
  TDBGrid ( sender ). Canvas . Font . Color  :=  clBlack ;
  TDBGrid ( sender ). DefaultDrawColumnCell ( Rect , DataCol , Column , State );
end ;

{=======================
  纵向斑马线
  =======================}
procedure  TForm1 . DBGridDrawColumnCell_D ( Sender :  TObject ;  const  Rect :  TRect ;
   DataCol :  Integer ;  Column :  TColumn ;  State :  TGridDrawState );
begin
   Case  DataCol  Mod  2  =  0  of
     True :  DbGrid1 . Canvas . Brush . Color :=  clinfobk ;  //偶数列用蓝色
     False :  DbGrid1 . Canvas . Brush . Color :=  clMoneygreen ;  //奇数列用浅绿色
   End ;
     if  (( State =[ gdSelected , gdFocused ]))  then
   TDBGrid ( sender ). Canvas . Font . Color  :=  clblue ;
   TDBGrid ( sender ). Canvas . pen . mode := pmmask ;
   DbGrid1 . DefaultDrawColumnCell  ( Rect , DataCol , Column , State );
end ;

{============================
  突出行显示
  ==========================}
procedure  TForm1 . DBGridDrawColumnCell_E ( Sender :  TObject ;  const  Rect :  TRect ;
   DataCol :  Integer ;  Column :  TColumn ;  State :  TGridDrawState );
begin
   Tdbgrid ( sender ). Color := clAqua ;
   Tdbgrid ( sender ). Options := Tdbgrid ( sender ). Options  +[ dgRowSelect ];
   if  (( State  =  [ gdSelected ])  or  ( State =[ gdSelected , gdFocused ]))  then
   DbGrid1 . Canvas . Brush . color := clRed ;  //当前行以红色显示，其它行使用背景的浅绿色
   DbGrid1 . Canvas . pen . mode := pmmask ;
   DbGrid1 . DefaultDrawColumnCell  ( Rect , DataCol , Column , State );
end ;

{=============================
  突出行列显示
  ===========================}
procedure  TForm1 . DBGridDrawColumnCell_F ( Sender :  TObject ;  const  Rect :  TRect ;
   DataCol :  Integer ;  Column :  TColumn ;  State :  TGridDrawState );
begin
   Tdbgrid ( sender ). Color := clAqua ;
   Tdbgrid ( sender ). Options := Tdbgrid ( sender ). Options  +[ dgRowSelect ];
   if  (( State  =  [ gdSelected ])  or  ( State =[ gdSelected , gdFocused ]))  then
   begin
     Case  DataCol  Mod  2  =  0  of
       True  :  DbGrid1 . Canvas . Brush . color := clRed ;  //当前选中行的偶数列显示红色
       False :  DbGrid1 . Canvas . Brush . color := clblue ;  //当前选中行的奇数列显示蓝色
     end ;
     DbGrid1 . Canvas . pen . mode := pmmask ;
     DbGrid1 . DefaultDrawColumnCell  ( Rect , DataCol , Column , State );
   end ;
end ;

{============================
    眼花缭乱 @_@
  ===========================}
procedure  TForm1 . DBGridDrawColumnCell_G ( Sender :  TObject ;  const  Rect :  TRect ;
   DataCol :  Integer ;  Column :  TColumn ;  State :  TGridDrawState );
begin
Case  Table1 . RecNo  mod  2  =  0  of //根据数据集的记录号进行判断
True  :  DbGrid1 . Canvas . Brush . color := Clinfobk ;  //偶数行用浅绿色显示
False :  DbGrid1 . Canvas . Brush . color :=  clmoneygreen ;  //奇数行用蓝色表示
end ;
If  (( State  =  [ gdSelected ])  or  ( State =[ gdSelected , gdFocused ]))  then
Case  DataCol  mod  2  =  0  of
True  :  DbGrid1 . Canvas . Brush . color := clRed ;  //当前选中行的偶数列用红色
False :  DbGrid1 . Canvas . Brush . color :=  clGreen ;  //当前选中行的奇数列用绿色表示
end ;
DbGrid1 . Canvas . pen . mode := pmMask ;
DbGrid1 . DefaultDrawColumnCell  ( Rect , DataCol , Column , State );
end ;

{图像}
procedure  TForm1 . DBGridDrawColumnCell_H ( Sender :  TObject ;  const  Rect :  TRect ;
   DataCol :  Integer ;  Column :  TColumn ;  State :  TGridDrawState );
var
Bmp :  TBitmap ;
begin
if  ( Column . Field . DataType  =  ftBLOB )  or  ( Column . Field . DataType  =  ftGraphic )  then
begin
  Bmp := TBitmap . Create ;
  try
  Bmp . Assign ( Column . Field );
  DBGrid1 . Canvas . StretchDraw ( Rect , Bmp );
  Bmp . Free ;
Except
  Bmp . Free ;
end ;
end ;
end ;

{============
 自动调整列宽
 =============}
function  DBGridRecordSize ( mColumn :  TColumn ):  Boolean ;
{ 返回记录数据网格列显示最大宽度是否成功 }
begin
Result  :=  False ;
if  not  Assigned ( mColumn . Field )  then  Exit ;
mColumn . Field . Tag  :=  Max ( mColumn . Field . Tag ,
  TDBGrid ( mColumn . Grid ). Canvas . TextWidth ( mColumn . Field . DisplayText ));
Result  :=  True ;
end ;  { DBGridRecordSize }

function  DBGridAutoSize ( mDBGrid :  TDBGrid ;  mOffset :  Integer  =  5 ):  Boolean ;
{ 返回数据网格自动适应宽度是否成功 }
var
I :  Integer ;
begin
Result  :=  False ;
if  not  Assigned ( mDBGrid )  then  Exit ;
if  not  Assigned ( mDBGrid . DataSource )  then  Exit ;
if  not  Assigned ( mDBGrid . DataSource . DataSet )  then  Exit ;
if  not  mDBGrid . DataSource . DataSet . Active  then  Exit ;
for  I  :=  0  to  mDBGrid . Columns . Count  -  1  do  begin
  if  not  mDBGrid . Columns [ I ]. Visible  then  Continue ;
  if  Assigned ( mDBGrid . Columns [ I ]. Field )  then
  mDBGrid . Columns [ I ]. Width  :=  Max ( mDBGrid . Columns [ I ]. Field . Tag ,
  mDBGrid . Canvas . TextWidth ( mDBGrid . Columns [ I ]. Title . Caption ))  +  mOffset
  else  mDBGrid . Columns [ I ]. Width  :=
  mDBGrid . Canvas . TextWidth ( mDBGrid . Columns [ I ]. Title . Caption )  +  mOffset ;
  mDBGrid . Refresh ;
end ;
Result  :=  True ;
end ;  { DBGridAutoSize }
///源代码结束
{列宽}
procedure  TForm1 . DBGridDrawColumnCell_I ( Sender :  TObject ;  const  Rect :  TRect ;
   DataCol :  Integer ;  Column :  TColumn ;  State :  TGridDrawState );
begin
    DBGridRecordSize ( Column );
end ;

{增加右键菜单}
procedure  TForm1 . DBGridDrawColumnCell_J ( Sender :  TObject ;  const  Rect :  TRect ;
   DataCol :  Integer ;  Column :  TColumn ;  State :  TGridDrawState );
begin
   vCurRect := Rect ; //vCurRect在实现部分定义
end ;


procedure  TForm1 . DBGridMouseDown ( Sender :  TObject ;  Button :  TMouseButton ;
   Shift :  TShiftState ;  X ,  Y :  Integer );
var
CurPost : TPoint ;
begin
GetCursorPos ( CurPost ); //获得鼠标当前坐标
if  ( y <= 17 )  and  ( x <= vCurRect . Right )  then
begin
  if  button = mbright  then
  begin
    PmTitle . Popup ( CurPost . x , CurPost . y );
end ;
end ;
end ;

2、其他技巧

{============
  文字也可以托放
  ============}
procedure  TForm1 . DBGridDragOver ( Sender ,  Source :  TObject ;  X ,  Y :  Integer ;
   State :  TDragState ;  var  Accept :  Boolean );
begin
    accept := true ;
end ;

procedure  TForm1 . DBGridDragDrop ( Sender ,  Source :  TObject ;  X ,  Y :  Integer );
begin
   if  Source <> Edit1  then  exit ;
   with  Sender  as  TDbGrid  do  begin
     Perform ( wm_LButtonDown , 0 , MakeLong ( x , y ));
     PerForm ( WM_LButtonUp , 0 , MakeLong ( x , y ));
     if   SelectedField . DataType = ftString  then
     begin
       SelectedField . Dataset . edit ;
       SelectedField . AsString := Edit1 . text ;
     end ;
   end ;
end ;
//指针控制
procedure  TForm1 . Button1Click ( Sender :  TObject );
begin
   Button1 . Enabled := false ;
   with  Dbgrid1 . DataSource . DataSet  do
   try
     if  not  checkbox1 . Checked  then   DisableControls ;
     first ;
     while  not  eof  do
     begin
      sleep ( 50 );
      application . ProcessMessages ;
      button1 . Caption := inttostr ( RecNo );
      next ;
     end ;
     first ;
   finally
     if  not  checkbox1 . Checked  then  EnableControls ;
   end ;
   Button1 . Enabled := True ;
   button1 . Caption := 'Go' ;
end ;

//定制下拉框
procedure  TForm1 . Button2Click ( Sender :  TObject );
var  i : integer ;
begin
   for  i := 0  to  dbgrid1 . Columns . Count - 1  do
     if  dbgrid1 . Columns [ i ]. FieldName = combobox1 . Text  then
     begin
       dbgrid1 . Columns [ 1 ]. PickList := memo1 . Lines ;
       TDrawGrid ( dbgrid1 ). col := i ;
       dbgrid1 . SetFocus ;
     end ;
end ;

 

{Excel}

//导出到excel
procedure  Tform1 . ExportDBGrid ( toExcel :  Boolean );
var
bm :  TBookmark ;
col ,  row :  Integer ;
sline :  String ;
mem :  TMemo ;
ExcelApp :  Variant ;
begin 
  Screen . Cursor  :=  crHourglass ;
  DBGrid1 . DataSource . DataSet . DisableControls ;
  bm  :=  DBGrid1 . DataSource . DataSet . GetBookmark ;
  DBGrid1 . DataSource . DataSet . First ;
  // create the Excel object
  if  toExcel  then
  begin
  ExcelApp  :=  CreateOleObject ( 'Excel.Application' );
  ExcelApp . WorkBooks . Add ( xlWBatWorkSheet );
  ExcelApp . WorkBooks [ 1 ]. WorkSheets [ 1 ]. Name  :=  'Grid Data' ;
end ;

  // First we send the data to a memo
  // works faster than doing it directly to Excel
  mem  :=  TMemo . Create ( Self );
  mem . Visible  :=  false ;
  mem . Parent  :=  self ;
  mem . Clear ;
  sline  :=  '' ;
  // add the info for the column names
  for  col  :=  0  to  DBGrid1 . FieldCount - 1  do
  sline  :=  sline  +  DBGrid1 . Fields [ col ]. DisplayLabel  +  #9 ;
mem . Lines . Add ( sline );
  // get the data into the memo
  for  row  :=  0  to  DBGrid1 . DataSource . DataSet . RecordCount - 1  do
  begin
  sline  :=  '' ;
  for  col  :=  0  to  DBGrid1 . FieldCount - 1  do
  sline  :=  sline  +  DBGrid1 . Fields [ col ]. AsString  +  #9 ;
mem . Lines . Add ( sline );
DBGrid1 . DataSource . DataSet . Next ;
end ;
  // we copy the data to the clipboard
mem . SelectAll ;
mem . CopyToClipboard ;
  // if needed, send it to Excel
// if not, we already have it in the clipboard
if  toExcel  then
begin
  ExcelApp . Workbooks [ 1 ]. WorkSheets [ 'Grid Data' ]. Paste ;
  ExcelApp . Visible  :=  true ;
end ;
  FreeAndNil ( mem );
//　FreeAndNil(ExcelApp);
  DBGrid1 . DataSource . DataSet . GotoBookmark ( bm );
  DBGrid1 . DataSource . DataSet . FreeBookmark ( bm );
  DBGrid1 . DataSource . DataSet . EnableControls ;
  Screen . Cursor  :=  crDefault ;
end ;

procedure  TForm1 . N4Click ( Sender :  TObject );
begin
   AboutBox . ShowModal ;
end ;


{
功能描述：把DBGrid输出到Excel表格（支持多Sheet）
设计：CoolSlob
日期：2002-10-23
支持：CoolSlob@163.com
调用格式：CopyDbDataToExcel([DBGrid1, DBGrid2]);
}

procedure  CopyDbDataToExcel ( Args :  array  of  const );
var
iCount ,  jCount :  Integer ;
XLApp :  Variant ;
Sheet :  Variant ;
I :  Integer ;
begin
Screen . Cursor  :=  crHourGlass ;
if  not  VarIsEmpty ( XLApp )  then
begin
  XLApp . DisplayAlerts  :=  False ;
  XLApp . Quit ;
  VarClear ( XLApp );
end ;

try
  XLApp  :=  CreateOleObject ( 'Excel.Application' );
Except
  Screen . Cursor  :=  crDefault ;
Exit ;
end ;

XLApp . WorkBooks . Add ;
XLApp . SheetsInNewWorkbook  :=  High ( Args )  +  1 ;

for  I  :=  Low ( Args )  to  High ( Args )  do
begin
  XLApp . WorkBooks [ 1 ]. WorkSheets [ I + 1 ]. Name  :=  TDBGrid ( Args [ I ]. VObject ). Name ;
  Sheet  :=  XLApp . Workbooks [ 1 ]. WorkSheets [ TDBGrid ( Args [ I ]. VObject ). Name ];
  if  not  TDBGrid ( Args [ I ]. VObject ). DataSource . DataSet . Active  then
  begin
  Screen . Cursor  :=  crDefault ;
  Exit ;
  end ;

  TDBGrid ( Args [ I ]. VObject ). DataSource . DataSet . first ;
  for  iCount  :=  0  to  TDBGrid ( Args [ I ]. VObject ). Columns . Count  -  1  do
  Sheet . Cells [ 1 ,  iCount  +  1 ]  :=  TDBGrid ( Args [ I ]. VObject ). Columns . Items [ iCount ]. Title . Caption ;

  jCount  :=  1 ;
  while  not  TDBGrid ( Args [ I ]. VObject ). DataSource . DataSet . Eof  do
  begin
  for  iCount  :=  0  to  TDBGrid ( Args [ I ]. VObject ). Columns . Count  -  1  do
  Sheet . Cells [ jCount  +  1 ,  iCount  +  1 ]  :=  TDBGrid ( Args [ I ]. VObject ). Columns . Items [ iCount ]. Field . AsString ;

  Inc ( jCount );
  TDBGrid ( Args [ I ]. VObject ). DataSource . DataSet . Next ;
  end ;
end ;

XlApp . Visible  :=  True ;
Screen . Cursor  :=  crDefault ;
end ; 

 

procedure  TForm1 . BitBtn1Click ( Sender :  TObject );
begin
    CopyDbDataToExcel ([ dbgrid1 ])
end ;