delphi能不能实现批量将dbf文件转换成xls文件
delphi能不能实现批量将dbf文件转换成xls文件？
望指教，谢谢
[解决办法]
有办法，ADO连接xls后． jet sql有一个in的关键字，除像sql中的in外,还有其它用法．
我一时说不清，你google一下吧．
[解决办法]
unit SwDBToFile;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
DB, comctrls, DBTables,SwCountQty;
type
ESwDBToFileError=class(Exception);
TSaveBuffer=procedure(Rows, Count: integer; Value: Variant) of object;
TSaveTitle=procedure of object;
TSetBuffer=procedure(Rows: integer; var Value: Variant) of object;
TSwDBToFile = class(TComponent)
private
{ Private declarations }
FSaveDialog: TSaveDialog;
FDataSource: TDataSource;
FProgressBar: TProgressBar;
FDBCount: TSwCountQty;
FHide: boolean;
FFileName: string;
FQuery: TQuery;
FCreateTable: TTable;
FOpenTable: TTable;
SaveFile: TextFile;
FBuffer: integer;
FFields: TList;
FSaveTitle: TSaveTitle;
FSetBuffer: TSetBuffer;
FSaveBuffer: TSaveBuffer;
FOle: Variant;
FOleB: Variant;
FOleS: Variant;
FSaveExcelOnly:boolean;
FSaveDBFOnly:boolean;
FMyTitle:string;
procedure GetTable;
procedure SetDBToText(Rows: integer; var Value: Variant);
procedure SaveDBToTextTxt(Rows, Count: integer; Value: Variant);
procedure DBToTextTxt;
procedure SaveDBToTextCsv(Rows, Count: integer; Value: Variant);
procedure DBToTextCsv;
procedure SaveDBToTextPrn(Rows, Count: integer; Value: Variant);
procedure DBToTextPrn;
procedure SaveTitleDBToWord;
procedure SaveDBToWord(Rows, Count: integer; Value: Variant);
procedure DBToWord;
procedure SaveTitleDBToDbase;
procedure SetDBToDbase(Rows: integer; var Value: Variant);
procedure DBToDbase;
procedure DBToParadox;
procedure SaveTitleDBToExcel;
procedure SetDBToExcel(Rows: integer; var Value: Variant);
procedure SaveDBToExcel(Rows, Count: integer; Value: Variant);
procedure DBToExcel;
protected
{ Protected declarations }
function SetExcelField(Col, Row: integer): string;
procedure SaveToFile(aType: integer; aFileName: string); virtual;
public
{ Public declarations }
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure AddFilter(aFilter: string);
procedure SetDefaultExt( aDefault: string);
procedure FilterClear;
procedure Execute;
property CountDataSet: TSwCountQty read FDBCount;
published
{ Published declarations }
property DataSource: TDataSource read FDataSource write FDataSource;
property ProgressBar: TProgressBar read FProgressBar write FProgressBar;
property Buffer: integer read FBuffer write FBuffer;
property SaveExcelOnly: boolean read FSaveExcelOnly write FSaveExcelOnly;
property SaveDBFOnly: boolean read FSaveDBFOnly write FSaveDBFOnly;
property MyTitle: string read FMyTitle write FMyTitle;
end;
procedure Register;
implementation
uses ComObj;
procedure Register;
begin
RegisterComponents('Data Controls', [TSwDBToFile]);
end;
constructor TSwDBToFile.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FDBCount:=TSwCountQty.Create(Self);
FFields:=TList.Create;
FSaveDialog:=TSaveDialog.Create(Self);
FSaveDialog.Title:='存储文件';
FSaveExcelOnly:=false;
FSaveDBFOnly:=false;
FMyTitle:='';
AddFilter('本文件(Tab 字符间隔)(*.TXT)|*.TXT|');
AddFilter('MicroSoft Excel 4.0 (*.XLS)|*.XLS|');
AddFilter('DBASE File (*.DBF)|*.DBF|');
SetDefaultExt('*.TXT');
FBuffer:=10;
end;
destructor TSwDBToFile.Destroy;
begin
FSaveDialog.Free;
FDBCount.Free;
FFields.Free;
inherited Destroy;
end;
procedure TSwDBToFile.FilterClear;
begin
FSaveDialog.Filter:='';
end;
procedure TSwDBToFile.SetDefaultExt(aDefault: string);
begin
FSaveDialog.DefaultExt:=aDefault;
end;
procedure TSwDBToFile.AddFilter(aFilter: string);
var
bFilter: string;
begin
bFilter:=FSaveDialog.Filter;
FSaveDialog.Filter:=bFilter+aFilter;
end;
procedure TSwDBToFile.SaveToFile(aType: integer; aFileName: string);
var
BookMark: TBookMark;
begin
DataSource.DataSet.UpdateCursorPos;
DataSource.DataSet.CursorPosChanged;
FFileName:=aFileName;
FQuery:=TQuery(FDataSource.DataSet);
BookMark:=FQuery.GetBookmark;
FQuery.DisableControls;
if FProgressBar<>nil then begin
if FDataSource.DataSet is TQuery then begin
FDBCount.DataSet:=TQuery(FDataSource.DataSet);
FDBCount.Open;
FProgressBar.Max:=FDBCount.FieldByName('aCount').AsInteger;
FProgressBar.Position:=0;
end else begin
FProgressBar.Max:=TTable(FDataSource.DataSet).RecordCount;
FProgressBar.Position:=0;
end;
end;
FHide:=False;
try
if aType=1 then DBToTextTxt
else if aType=2 then DBToExcel
else if aType=3 then DBToDbase
finally
FDBCount.Close;
FDBCount.UnPrepare;
FQuery.EnableControls;
FQuery.GotoBookMark(BookMark);
FQuery.FreeBookMark(BookMark);
end;
end;
procedure TSwDBToFile.Execute;
var
aFileName: string;
FilterIndex: integer;
MsgResult: Word;
begin
if FDataSource=nil then raise ESwDBToFileError.Create('资料库没有设定');
if FDataSource.State=dsInactive then raise ESwDBToFileError.Create('资料库没有打开');
FSaveTitle:=nil;
FSetBuffer:=nil;
FSaveBuffer:=nil;
if SaveExcelOnly=true then begin
FSaveDialog.filter:='Excel文件(*.XLS)|*.XLS|';
end;
if SaveDBFOnly=true then begin
FSaveDialog.filter:='DBF文件(*.DBF)|*.DBF|';
end;
FSaveDialog.FileName:=FMyTitle;
if FSaveDialog.Execute then begin
aFileName:=FSaveDialog.FileName;
FilterIndex:=FSaveDialog.FilterIndex;
MsgResult:=mrYes;
//if FileExists(aFileName) then
// MsgResult:=MessageDlg( aFileName+'文件已经存在，是否复盖？',mtConfirmation, [mbYes, mbNo], 0);
if MsgResult=mrYes then
if FSaveExcelOnly then
SaveToFile(2, aFileName)
else
if FSaveDBFOnly then
SaveToFile(3, aFileName)
else
SaveToFile(FilterIndex, aFileName);
end;
end;
procedure TSwDBToFile.SetDBToText(Rows: integer; var Value: Variant);
var
iLoop: integer;
Field: TField;
begin
for iLoop:=0 to FFields.Count-1 do begin
Field:=FFields[iLoop];
if Field.DataType=ftDateTime then
Value[Rows, iLoop+1]:=FormatDateTime('YYYY/MM/DD HH:NN:SS',Field.AsDateTime)
else if Field.DataType=ftDate then
Value[Rows, iLoop+1]:=FormatDateTime('YYYY/MM/DD',Field.AsDateTime)
else if Field.DataType=ftTime then
Value[Rows, iLoop+1]:=FormatDateTime('HH:NN:SS',Field.AsDateTime)
else Value[Rows, iLoop+1]:=Field.Text;
end;
end;
procedure TSwDBToFile.SaveDBToTextTxt(Rows, Count: integer; Value: Variant);
var
iLoop, iLoop1: integer;
Line: string;
begin
for iLoop:=1 to Rows do begin
Line:='';
for iLoop1:=1 to FFields.Count do begin
Line:=Line+Value[iLoop, iLoop1];
if iLoop1<>FFields.Count then Line:=Line+Chr(9);
end;
Writeln(SaveFile, Line);
end;
end;
procedure TSwDBToFile.DBToTextTxt;
begin
FSetBuffer:=SetDBToText;
FSaveBuffer:=SaveDBToTextTxt;
AssignFile(SaveFile, FFileName);
ReWrite(SaveFile);
GetTable;
CloseFile(SaveFile);
end;
procedure TSwDBToFile.SaveDBToTextCsv(Rows, Count: integer; Value: Variant);
var
iLoop, iLoop1: integer;
Line: string;
begin
for iLoop:=1 to Rows do begin
Line:='';
for iLoop1:=1 to FFields.Count do begin
Line:=Line+Value[iLoop, iLoop1];
if iLoop1<>FFields.Count then Line:=Line+',';
end;
Writeln(SaveFile, Line);
end;
end;
[解决办法]
procedure TSwDBToFile.DBToTextCsv;
begin
FSetBuffer:=SetDBToText;
FSaveBuffer:=SaveDBToTextCsv;
AssignFile(SaveFile, FFileName);
ReWrite(SaveFile);
GetTable;
CloseFile(SaveFile);
end;
procedure TSwDBToFile.SaveDBToTextPrn(Rows, Count: integer; Value: Variant);
var
iLoop, iLoop1: integer;
Line: string;
begin
for iLoop:=1 to Rows do begin
Line:='';
for iLoop1:=1 to FFields.Count do begin
Line:=Line+Value[iLoop, iLoop1];
if iLoop1<>FFields.Count then Line:=Line+' ';
end;
Writeln(SaveFile, Line);
end;
end;
procedure TSwDBToFile.DBToTextPrn;
begin
FSetBuffer:=SetDBToText;
FSaveBuffer:=SaveDBToTextPrn;
AssignFile(SaveFile, FFileName);
ReWrite(SaveFile);
GetTable;
CloseFile(SaveFile);
end;
procedure TSwDBToFile.SaveTitleDBToWord;
var
iLoop: integer;
Line: string;
Field: TField;
begin
Line:='';
for iLoop:=0 to FFields.Count-1 do begin
Field:=FFields[iLoop];
Line:=Line+Field.DisplayLabel;
if iLoop<>FFields.Count-1 then Line:=Line+',';
end;
Line:=Line+Chr(13);
FOle.Insert(Line);
end;
procedure TSwDBToFile.SaveDBToWord(Rows, Count: integer; Value: Variant);
var
iLoop, iLoop1: integer;
Line: string;
begin
for iLoop:=1 to Rows do begin
Line:='';
for iLoop1:=1 to FFields.Count do begin
Line:=Line+Value[iLoop, iLoop1];
if iLoop1<>FFields.Count then Line:=Line+',';
end;
Line:=Line+Chr(13);
FOle.Insert(Line);
end;
end;
procedure TSwDBToFile.DBToWord;
var
MsgResult: Word;
begin
try
MsgResult:=MessageDlg( ' MicroSoft Word',mtConfirmation, [mbYes, mbNo], 0);
if MsgResult=mrYes then FHide:=True;
FSaveTitle:=SaveTitleDBToWord;
FSetBuffer:=SetDBToText;
FSaveBuffer:=SaveDBToWord;
FOle:=CreateOleObject('Word.Basic');
FOle.AppHide;
FOle.FileNewDefault;
GetTable;
try
FOLE.FileSaveAs(Name:=FFileName, Format:=0);
if FHide then begin
FOLE.FileClose(1);
FOLE.AppClose;
end else FOLE.AppShow;
except
FOLE.AppClose;
raise ESwDBToFileError.Create('无法保存'+FFileName);
end;
except
raise ESwDBToFileError.Create('无法打开 Microsoft Word !');
end;
end;
procedure TSwDBToFile.SaveTitleDBToDbase;
var
iLoop: integer;
Field: TField;
FieldDef: TFieldDef;
begin
for iLoop:=0 to FFields.Count-1 do begin
Field:=FFields[iLoop];
//FCreateTable.FieldDefs.Add(Field.FieldName, Field.DataType,Field.Size, False);
//FieldDef:=FCreateTable.FieldDefs.Find(Field.FieldName);
FCreateTable.FieldDefs.Add(Field.FullName, Field.DataType,Field.Size, False);
FieldDef:=FCreateTable.FieldDefs.Find(Field.FullName);
FieldDef.CreateField(Self);
end;
FCreateTable.CreateTable;
FOpenTable.Open;
end;
procedure TSwDBToFile.SetDBToDbase(Rows: integer; var Value: Variant);
var
iLoop: integer;
Field: TField;
begin
FOpenTable.Append;
for iLoop:=0 to FFields.Count-1 do begin
Field:=FFields[iLoop];
FOpenTable.Fields[iLoop].Value:=Field.Value;
end;
FOpenTable.Post;
end;
procedure TSwDBToFile.DBToDbase;
begin
FSaveTitle:=SaveTitleDBToDbase;
FSetBuffer:=SetDBToDbase;
FCreateTable:=TTable.Create(nil);
FOpenTable:=TTable.Create(nil);
try
// FCreateTable.TableType:=ttDBase;
FCreateTable.TableType:=ttFoxPro;
FCreateTable.DatabaseName:=ExtractFilePath(FFileName);
FCreateTable.TableName:=ExtractFileName(FFileName);
FOpenTable.TableType:=ttDBase;
FOpenTable.DatabaseName:=ExtractFilePath(FFileName);
FOpenTable.TableName:=ExtractFileName(FFileName);
GetTable;
finally
FOpenTable.Close;
FOpenTable.Free;
FCreateTable.Close;
FCreateTable.Free;
end;
end;
procedure TSwDBToFile.DBToParadox;
begin
FSaveTitle:=SaveTitleDBToDbase;
FSetBuffer:=SetDBToDbase;
FCreateTable:=TTable.Create(nil);
FOpenTable:=TTable.Create(nil);
try
FCreateTable.TableType:=ttParadox;
FCreateTable.DatabaseName:=ExtractFilePath(FFileName);
FCreateTable.TableName:=ExtractFileName(FFileName);
FOpenTable.TableType:=ttParadox;
FOpenTable.DatabaseName:=ExtractFilePath(FFileName);
FOpenTable.TableName:=ExtractFileName(FFileName);
GetTable;
finally
FOpenTable.Close;
FOpenTable.Free;
FCreateTable.Close;
FCreateTable.Free;
end;
end;
function TSwDBToFile.SetExcelField(Col, Row: integer): string;
begin
if (Col div 26)=0 then Result:=chr(65+(Col mod 26))+IntToStr(Row)
else Result:=chr(65+(Col div 26))+chr(65+(Col mod 26))+IntToStr(Row);
end;
procedure TSwDBToFile.SaveTitleDBToExcel;
var
iLoop: integer;
Field: TField;
iBegin:integer;
begin
if FMyTitle<>'' then
iBegin:=3
else
iBegin:=1;
for iLoop:=0 to FFields.Count-1 do begin
Field:=FFields[iLoop];
FOleS.Cells[iBegin, iLoop+1].Value:=Field.displaylabel;
end;
end;
procedure TSwDBToFile.SetDBToExcel(Rows: integer; var Value: Variant);
var
iLoop: integer;
Field: TField;
begin
for iLoop:=0 to FFields.Count-1 do begin
Field:=FFields[iLoop];
if Field.DataType=ftDateTime then
Value[Rows, iLoop+1]:=FormatDateTime('YYYY/MM/DD HH:NN:SS',Field.AsDateTime)
else if Field.DataType=ftDate then
Value[Rows, iLoop+1]:=FormatDateTime('YYYY/MM/DD',Field.AsDateTime)
else if Field.DataType=ftTime then
Value[Rows, iLoop+1]:=FormatDateTime('HH:NN:SS',Field.AsDateTime)
else if Field.DataType=ftString then
Value[Rows, iLoop+1]:=#39+Field.Text
else Value[Rows, iLoop+1]:=Field.Text;
end;
end;
procedure TSwDBToFile.SaveDBToExcel(Rows, Count: integer; Value: Variant);
var
sCol, sRow, eCol, eRow: integer;
begin
sRow:=(Count-Rows)+2;
sCol:=1;
eRow:=Count+1;
eCol:=FFields.Count;
try
FOleS.Range[FOleS.Cells[sRow, sCol], FOleS.Cells[eRow, eCol]].Value:=Value;
except
FOleS.Range[FOleS.Cells[sRow, sCol], FOleS.Cells[eRow, eCol]]:=Value;
end;
end;
procedure TSwDBToFile.DBToExcel;
var
MsgResult: Integer;
begin
// MsgResult:= MessageDlg( '是否打开 MicroSoft Excel',mtConfirmation, [mbYes, mbNo], 0);
// MsgResult :=Application.MessageBox('是否打开 MicroSoft Excel','提示',MB_YESNO+MB_ICONINFORMATION);
// if MsgResult<>IdYes then FHide:=True;
FHide:=True;
FSaveTitle:=SaveTitleDBToExcel;
FSetBuffer:=SetDBToExcel;
FSaveBuffer:=SaveDBToExcel;
try
FOle:=CreateOleObject('Excel.Application');
FOleB:=FOle.WorkBooks.Add;
FOleS:=FOle.WorkSheets.Add;
if FMyTitle<>'' then begin
FOleS.Cells[1, 1].value:=FMyTitle;
FOleS.Cells[1, 1].Font.size:=20;
FOleS.Cells[1, 1].Font.bold:=true;
//FOleS.Cells[1, 1].alignment:=2;
end;
FOle.Visible:=False;
GetTable;
try
FOleS.SaveAs(FFileName);
if FHide then FOle.Quit
else FOle.Visible:=True;
except
FOle.Quit;
raise ESwDBToFileError.Create('无法存储 '+FFileName);
end;
except
try
FOle:=CreateOleObject('Excel.Application.8');
FOleB:=FOle.WorkBooks.Add;
FOleS:=FOle.WorkSheets.Add;
FOle.Visible:=False;
GetTable;
try
FOleS.SaveAs(FFileName);
if FHide then FOle.Quit
else FOle.Visible:=True;
except
FOle.Quit;
raise ESwDBToFileError.Create('无法存储 '+FFileName);
end;
except
raise ESwDBToFileError.Create('无法启动 Excel !');
end;
end;
end;
procedure TSwDBToFile.GetTable;
var
iLoop, Rows, Count: integer;
Field: TField;
Value: Variant;
begin
if FBuffer=0 then FBuffer:=FProgressBar.Max;
FFields.Clear;
for iLoop:=0 to FQuery.FieldCount-1 do begin
Field:=FQuery.Fields[iLoop];
if (Field.Visible) and (Field.dataType in
[ftString,ftSmallint,ftInteger,ftWord, ftBoolean,ftFloat,ftCurrency,
ftDate,ftTime,ftDateTime,ftAutoInc]) then FFields.Add(FQuery.Fields[iLoop]);
end;
if Assigned(FSaveTitle) then FSaveTitle;
Value:=VarArrayCreate([1, FBuffer, 1, FFields.Count], varVariant);
if FMyTitle<>'' then
begin
Rows:=2;
Count:=2;
end
else
begin
Rows:=0;
Count:=0;
end;
FQuery.First;
while not FQuery.EOF do begin
inc(Rows);
inc(Count);
if FProgressBar<>nil then FProgressBar.Position:=Count;
if Assigned(FSetBuffer) then FSetBuffer(Rows, Value);
if Rows=FBuffer then begin
if Assigned(FSaveBuffer) then FSaveBuffer(Rows, Count, Value);
Rows:=0;
end;
FQuery.Next;
end;
if Rows>0 then begin
if Assigned(FSaveBuffer) then FSaveBuffer(Rows, Count, Value);
end;
if Assigned(FSaveTitle) then FSaveTitle;
end;
end.
//不要再问我，批量如何处理，人不能太懒！否则下次没有人再愿意帮你！
[解决办法]
留名先，说不定以后用的着。
[解决办法]
mark
