implementation uses
BDE;//做PACK必须引用次单元里的函数 {$R
*.DFM} procedure TfrmPack.FormCreate(Sender:
TObject); var DBName:String; begin DBName:=ExtractFilePath(Application.ExeName);//得到数据库的位置 {设置Table} tblDBASE.DatabaseName:=DBName; tblParadox.DatabaseName:=DBName; tblDBASE.TableName:='dbsTest.dbf'; tblParadox.TableName:='pdxTest.db'; tblDBASE.Active:=True; tblParadox.Active:=True; end; {物理删除数据库记录Pack a Paradox or dBASE table} // The
table must be opened execlusively before calling this
procedure... procedure TFrmPack.PackTable(FTable:
TTable); var Props: CURProps; hDb:
hDBIDb; TableDesc: CRTblDesc; begin FTable.Active
:= False; {当数据库打开失败时,这个循环语句能够让用户重试} repeat try FTable.Exclusive
:= True; FTable.Active := True; {如果正常打开数据库,则退出循环} Break; except on
EDatabaseError do if Application.MessageBox( '以独占方式打开数据库时,出现错误---重试否?', '数据库错误', MB_OKCANCEL + MB_DEFBUTTON1) <>
IDOK then Exit; end; until False;
try {Check()用于校正和报告DBI底层错误;DbiGetCursorProps()用于取表光标属性} Check(DbiGetCursorProps(FTable.Handle,
Props));// 获得表的属性已得到表的类型 {如果是Paradox 表, 必须调用 DbiDoRestructure,重建数据库结构} if
(Props.szTableType = szPARADOX)
then begin FillChar(TableDesc, sizeof(TableDesc),
0); {从数据表光标获取数据库句柄} Check(DbiGetObjFromObj(hDBIObj(FTable.Handle),
objDATABASE, hDBIObj(hDb))); {设置表的描述结构的Name/Type/bPack属性} StrPCopy(TableDesc.szTblName,
FTable.TableName); StrPCopy(TableDesc.szTblType,
Props.szTableType); TableDesc.bPack := True; {关闭表并调用api} FTable.Close; Application.ProcessMessages; Check(DbiDoRestructure(hDb,
1, @TableDesc, nil, nil, nil,
False)); Application.ProcessMessages; FTable.Open; end {
如果是 dBASE 表,
只需要调用DbiPackTable...} else if
(Props.szTableType = szDBASE)
then begin Application.ProcessMessages; Check(DbiPackTable(FTable.DBHandle,
FTable.Handle, nil, szDBASE,
True)); Application.ProcessMessages; end {不是dBase和Paradox表} else raise
EDatabaseError.Create('数据库必须是 Paradox 或者 dBASE
类型,才能进行物理删除操作!!'); finally FTable.Active :=
False; FTable.Exclusive := False; FTable.Active :=
True; end; end;
procedure
TfrmPack.BitBtndBaseClick(Sender: TObject); begin if
OpenPictureDlg.Execute
then DBImage1.Picture.LoadFromFile(OpenPictureDlg.FileName); end; procedure
TfrmPack.BitBtnParadoxClick(Sender: TObject); begin if
OpenPictureDlg.Execute
then DBImage2.Picture.LoadFromFile(OpenPictureDlg.FileName); end; procedure
TfrmPack.BitBtnPackdBASEClick(Sender:
TObject); begin PackTable(tbldBASE);//物理删除dDBSE库 end; procedure
TfrmPack.BitBtnPackParadoxClick(Sender:
TObject); begin PackTable(tblParadox);//物理删除Paradox库 end;
注：本站部分文章源于互联网，版权归原作者所有！如有侵权，请原作者与本站联系，本站将立即删除！ 本站文章除特别注明外均可转载，但需注明出处！ [MinTao学以致用网] 
