由DBGridEh导出EXCEL改写的! 很简陋, 大家有兴趣的可以再改写一下! 希望做地更漂亮(300分)

//好久没有写东西了今天发情. 就乱写呵呵! 别见笑啊^^
unit DataSetToExcel;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, DB, ComCtrls, ExtCtrls, StdCtrls, Gauges, ShellApi;
type
TDataSetToExcel = class(TComponent)
private
FCol: integer;
{行}
FRow: integer;
{列}
Stream: TStream;
{输出文件流}
FBookMark: TBookmark;

FDataSet: TDataSet;
Fbegin
Date: TCaption;
{开始日期}
FTitleName: TCaption;
{Excel文件标题}
FEndDate: TCaption;
{结束日期}
FUserName: TCaption;
{制表人}
FFileName: String;
{保存文件名}
procedure SetDataSet(const Value: TDataSet);
procedure Setbegin
Date(const Value: TCaption);
procedure SetEndDate(const Value: TCaption);
procedure SetTitleName(const Value: TCaption);
procedure SetUserName(const Value: TCaption);
procedure SetFileName(const Value: String);
procedure IncColRow;
procedure WriteBlankCell;
{写空单元格}
{写数字单元格}
procedure WriteFloatCell(const AValue:do
uble;
const IncStatus: Boolean=True);
{写整型单元格}
procedure WriteIntegerCell(const AValue: Integer;
const IncStatus: Boolean=True);
{写字符单元格}
procedure WriteStringCell(const AValue: string;
const IncStatus: Boolean=True);
procedure WritePrefix;
procedure WriteSuffix;
procedure WriteHeader;
{输出Excel标题}
procedure WriteTitle;
{输出Excel列标题}
procedure WriteDataCell;
{输出数据集内容}
procedure WriteFooter;
{输出Excel表脚}
procedure SaveStream(aStream: TStream);
protected
{ Protected declarations }
public
constructor Create(AOwner: TComponent);
override;
destructor Destroy;
override;
procedure ExportToExcel;
{输出Excel文件}
published
property DataSet: TDataSet read FDataSet write SetDataSet;
property TitleName: TCaption read FTitleName write SetTitleName;
property begin
Date: TCaption read Fbegin
Date write Setbegin
Date;
property EndDate: TCaption read FEndDate write SetEndDate;
property UserName: TCaption read FUserName write SetUserName;
property FileName: String read FFileName write SetFileName;
end;

var
CXlsBof: array[0..5] of Word = ($809, 8, 0, $10, 0, 0);
CXlsEof: array[0..1] of Word = ($0A, 00);
CXlsLabel: array[0..5] of Word = ($204, 0, 0, 0, 0, 0);
CXlsNumber: array[0..4] of Word = ($203, 14, 0, 0, 0);
CXlsRk: array[0..4] of Word = ($27E, 10, 0, 0, 0);
CXlsBlank: array[0..4] of Word = ($201, 6, 0, 0, $17);

procedure Register;
implementation
procedure Register;
begin
RegisterComponents('ExportToExcel', [TDataSetToExcel]);
end;

{ TDataSetToExcel }
constructor TDataSetToExcel.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
end;

destructor TDataSetToExcel.Destroy;
begin

inherited;
end;

procedure TDataSetToExcel.ExportToExcel;
var
FileStream: TFileStream;
Msg: String;
begin
//如果数据集为空或没有打开则退出
if (DataSet.IsEmpty) or (not DataSet.Active) then
exit;
//如果保存的文件名为空则退出
if Trim(FileName) = '' then
exit;

Screen.Cursor := crHourGlass;
try
try
if FileExists(FileName) then
begin
Msg := '已存在文件（' + FileName + '），是否覆盖？';
if Application.MessageBox(PChar(Msg),'提示',MB_YESNO+MB_ICONQUESTION+MB_DEFBUTTON2) = IDYES then
begin
//删除文件
DeleteFile(FileName)
end else
exit;
end;
//显示进度窗体
FileStream := TFileStream.Create(FileName, fmCreate);
try
//输出文件
SaveStream(FileStream);
finally
FileStream.Free;
end;
//打开Excel文件
ShellExecute(0, 'Open', PChar(FileName), nil, nil, SW_SHOW);
except
end;
finally
Screen.Cursor := crDefault;
end;
end;

procedure TDataSetToExcel.IncColRow;
begin
if FCol = DataSet.FieldCount - 1 then
begin
Inc(FRow);
FCol := 0;
end else
Inc(FCol);
end;

procedure TDataSetToExcel.SaveStream(aStream: TStream);
begin
FCol := 0;
FRow := 0;
Stream := aStream;
//输出前缀
WritePrefix;
//输出表格标题
WriteHeader;
//输出列标题
WriteTitle;
//输出数据集内容
WriteDataCell;
//输出表脚
WriteFooter;
//输出后缀
WriteSuffix;
end;

procedure TDataSetToExcel.Setbegin
Date(const Value: TCaption);
begin
Fbegin
Date := Value;
end;

procedure TDataSetToExcel.SetDataSet(const Value: TDataSet);
begin
FDataSet := Value;
end;

procedure TDataSetToExcel.SetEndDate(const Value: TCaption);
begin
FEndDate := Value;
end;

procedure TDataSetToExcel.SetFileName(const Value: String);
begin
FFileName := Value;
end;

procedure TDataSetToExcel.SetTitleName(const Value: TCaption);
begin
FTitleName := Value;
end;

procedure TDataSetToExcel.SetUserName(const Value: TCaption);
begin
FUserName := Value;
end;

procedure TDataSetToExcel.WriteBlankCell;
begin
CXlsBlank[2] := FRow;
CXlsBlank[3] := FCol;
Stream.WriteBuffer(CXlsBlank, SizeOf(CXlsBlank));
IncColRow;
end;

procedure TDataSetToExcel.WriteDataCell;
var
i: integer;
begin
FBookMark := DataSet.GetBookmark;
try
DataSet.First;
while not DataSet.Eofdo
begin
for i := 0 to DataSet.FieldCount - 1do
begin
if DataSet.Fields.IsNull or (not DataSet.Fields.Visible) then
WriteBlankCell
else
begin
case DataSet.Fields.DataType of
ftSmallint, ftInteger, ftWord, ftAutoInc, ftBytes:
WriteIntegerCell(DataSet.Fields.AsInteger);
ftFloat, ftCurrency, ftBCD:
WriteFloatCell(DataSet.Fields.AsFloat);
else
if DataSet.Fields Is TBlobfield then
// 此类型的字段(图像等)暂无法读取显示
WriteStringCell('')
else
WriteStringCell(DataSet.Fields.AsString);
end;
end;
end;
//显示进度条进度过程
DataSet.Next;
end;
finally
if DataSet.BookmarkValid(FBookMark) then
DataSet.GotoBookmark(FBookMark);
end;
end;

procedure TDataSetToExcel.WriteFloatCell(const AValue:do
uble;
const IncStatus: Boolean);
begin
CXlsNumber[2] := FRow;
CXlsNumber[3] := FCol;
Stream.WriteBuffer(CXlsNumber, SizeOf(CXlsNumber));
Stream.WriteBuffer(AValue, 8);
if IncStatus then
IncColRow;
end;

procedure TDataSetToExcel.WriteFooter;
begin

end;

procedure TDataSetToExcel.WriteHeader;
var
OpName, OpDate: String;
begin
//标题
FCol := 3;
WriteStringCell(TitleName,False);
FCol := 0;
Inc(FRow);
{if Trim(begin
Date) <> '' then
begin
//开始日期
FCol := 0;
WriteStringCell(begin
Date,False);
FCol := 0
end;

if Trim(EndDate) <> '' then
begin
//结束日期
FCol := 5;
WriteStringCell(EndDate,False);
FCol := 0;
end;

if (Trim(begin
Date) <> '') or (Trim(EndDate) <> '') then
Inc(FRow);
//制表人
OpName := '制表人：' + UserName;
FCol := 0;
WriteStringCell(OpName,False);
FCol := 0;
//制表时间
OpDate := '制表时间：' + DateTimeToStr(Now);
FCol := 5;
WriteStringCell(OpDate,False);
FCol := 0;
Inc(FRow);
}
end;

procedure TDataSetToExcel.WriteIntegerCell(const AValue: Integer;
const IncStatus: Boolean);
var
V: Integer;
begin
CXlsRk[2] := FRow;
CXlsRk[3] := FCol;
Stream.WriteBuffer(CXlsRk, SizeOf(CXlsRk));
V := (AValue Shl 2) Or 2;
Stream.WriteBuffer(V, 4);
if IncStatus then
IncColRow;
end;
procedure TDataSetToExcel.WriteStringCell(const AValue: string;
const IncStatus: Boolean);
var
L: integer;
begin
L := Length(AValue);
CXlsLabel[1] := 8 + L;
CXlsLabel[2] := FRow;
CXlsLabel[3] := FCol;
CXlsLabel[5] := L;
Stream.WriteBuffer(CXlsLabel, SizeOf(CXlsLabel));
Stream.WriteBuffer(Pointer(AValue)^, L);
if IncStatus then
IncColRow;
end;

procedure TDataSetToExcel.WritePrefix;
begin
Stream.WriteBuffer(CXlsBof, SizeOf(CXlsBof));
end;

procedure TDataSetToExcel.WriteSuffix;
begin
Stream.WriteBuffer(CXlsEof, SizeOf(CXlsEof));
end;

procedure TDataSetToExcel.WriteTitle;
var
strList: TStrings;
j: integer;
begin
try
strList := TStringList.Create;
DataSet.GetFieldNames(strList);
for j := 0 to strList.Count - 1do
begin
FCol := j;
WriteStringCell(strList.Strings[j], False);
end;
Inc(FRow);
FCol := 0;
finally
strList.Free;
end;
end;

end.

收藏,学习,呵呵

可不可以导出多表头先

学习~~

不错，代码风格很好，有注释

还在学习中

你这个比EH的还丑陋,

代码太多了吧，你导10w条记录，20列你看看要多少时间，如果能够接受再说