以极简代码实现导出数据集到Excel文件
最近要实现将数据集导出到Excel的功能，同时希望做成标准功能，只需传入数据集对象和目标文件名即可。也不打算使用第三方组件，代码尽量精简。
1.直接写文件方式导出数据集到Excel表
首先上网搜索一翻，除了常见的Ole方式，确实找到了通过FileStream直接写文件的方法，参考着一翻改写，得到以下通用功能。
var
arXlsBegin: array[0..5] of Word = ($809, 8, 0, $10, 0, 0);
arXlsEnd: array[0..1] of Word = ($0A, 00);
arXlsString: array[0..5] of Word = ($204, 0, 0, 0, 0, 0);
arXlsNumber: array[0..4] of Word = ($203, 14, 0, 0, 0);
arXlsInteger: array[0..4] of Word = ($27E, 10, 0, 0, 0);
arXlsBlank: array[0..4] of Word = ($201, 6, 0, 0, $17);
//入参：
//ADataSet：要导出的数据集
//FileName：Excel文件名
//bWriteTitle：是否写入列标头
Procedure ExportExcelFile(ADataSet: TDataSet; FileName: string; bWriteTitle: Boolean);
var
i: integer;
Col, row: word;
ABookMark: TBookMark;
aFileStream: TFileStream;
//增加行列号
procedure incColRow;
begin
if Col = ADataSet.FieldCount - 1 then
begin
Inc(Row);
Col :=0;
end
else
Inc(Col);
end;
//写字符串数据
procedure WriteStringCell(AValue: AnsiString);
var
L: Word;
begin
L := Length(AValue);
arXlsString[1] := 8 + L;
arXlsString[2] := Row;
arXlsString[3] := Col;
arXlsString[5] := L;
aFileStream.WriteBuffer(arXlsString, SizeOf(arXlsString));
aFileStream.WriteBuffer(Pointer(AValue)^, L);
IncColRow;
end;
//写整数
procedure WriteIntegerCell(AValue: integer);
var
V: Integer;
begin
arXlsInteger[2] := Row;
arXlsInteger[3] := Col;
aFileStream.WriteBuffer(arXlsInteger, SizeOf(arXlsInteger));
V := (AValue shl 2) or 2;
aFileStream.WriteBuffer(V, 4);
IncColRow;
end;
//写浮点数
procedure WriteFloatCell(AValue: double);
begin
arXlsNumber[2] := Row;
arXlsNumber[3] := Col;
aFileStream.WriteBuffer(arXlsNumber, SizeOf(arXlsNumber));
aFileStream.WriteBuffer(AValue, 8);
IncColRow;
end;
begin
//文件存在，先删除
if FileExists(FileName) then
DeleteFile(PChar(FileName));
aFileStream := TFileStream.Create(FileName, fmCreate);
try
//写文件头
aFileStream.WriteBuffer(arXlsBegin, SizeOf(arXlsBegin));
//写列头
Col := 0; Row := 0;
if bWriteTitle then
begin
for i := 0 to aDataSet.FieldCount - 1 do
WriteStringCell(aDataSet.Fields[i].DisplayLabel);
end;
//写数据集中的数据
ADataSet.DisableControls;
ABookMark := ADataSet.GetBookmark;
ADataSet.First;
while not aDataSet.Eof do
begin
for i := 0 to ADataSet.FieldCount - 1 do
case ADataSet.Fields[i].DataType of
ftSmallint, ftInteger, ftWord, ftAutoInc, ftBytes:
WriteIntegerCell(ADataSet.Fields[i].AsInteger);
ftFloat, ftCurrency, ftBCD:
WriteFloatCell(ADataSet.Fields[i].AsFloat)
else
WriteStringCell(ADataSet.Fields[i].AsAnsiString);
end;
aDataSet.Next;
end;
//写文件尾
AFileStream.WriteBuffer(arXlsEnd, SizeOf(arXlsEnd));
if ADataSet.BookmarkValid(ABookMark) then
ADataSet.GotoBookmark(ABookMark);
finally
AFileStream.Free;
ADataSet.EnableControls;
end;
end;
代码很精简，函数调用后成功生成Excel文件，使用WPS打开一
切正常，似乎很顺利。
2.来自“受保护视图”的坑
直到使用office 2019打开文件，一直卡在启动logo，好几分钟没有变化。
耐心等待打开后Excel界面也是非常卡顿，完全操作不了。
询问AI，答：触发了Excel的受保护视图。大概是印度阿三写了很多死循环吧。如果要坚持打开可以修改Excel的文件阻止设定。
经过一翻摸索，在Excel选项→信任中心→文件阻止设置里，把Excel2 ～ Excel95的勾都去掉后确定可以畅顺的打开文件了。
但是这个解决方法自己玩玩可以，交付给客户绝对不行。
3.对Excel文件版本的探索
既然问题发生Excel文件的版本上，那前面的代码空间生成是哪个版本？把文件丢给AI秒出答案：是Excel2版本！没想到这样的古董居然让我碰上了。
那就让AI接手改吧，代码给AI要求修改为生成Excel97-2003版本的BIFF格式文件（注意Excel97-2003版本是一版本，不是从97～2003）。
首先让DeepSeek改，7、8轮下来依旧有问题，最后的3轮它已经不停的劝我直接使用第三方组件更简单。
换kimi情况差不多，后面也是不停的劝说使用第三方组件。
最后换智谱，它倒是老实的改代码，可惜也是一堆问题，不是打不开、就是数据严重错位。
4.生成XML格式的Excel文件
AI是死的，人是活的。BIFF格式有难度，那改为XML格式又会怎样呢？
这次AI很快出答案，并且运行一次通过，相当Nice！
以下代码仅160行，它支持传入列宽数组，指定Excel表各列的宽度。
Procedure ExportExcelFile(ADataSet: TDataSet; FileName: string; bWriteTitle: Boolean; ColWidths: array of Integer);
var
i, RowIdx, ColIdx: integer;
ABookMark: TBookMark;
ZipFile: TZipFile;
XMLData: TStringList;
// 辅助函数：将列索引(0,1,2...)转换为Excel列名(A,B,C...Z,AA,AB...)
function ColLetter(Col: Integer): string;
begin
if Col < 26 then
Result := Char(Ord('A') + Col)
else
Result := Char(Ord('A') + (Col div 26) - 1) + Char(Ord('A') + (Col mod 26));
end;
// 辅助函数：转义XML特殊字符，防止报错
function EscapeXML(const S: string): string;
begin
Result := S;
Result := StringReplace(Result, '&', '&', [rfReplaceAll]);
Result := StringReplace(Result, '<', '<', [rfReplaceAll]);
Result := StringReplace(Result, '>', '>', [rfReplaceAll]);
Result := StringReplace(Result, '"', '"', [rfReplaceAll]);
Result := StringReplace(Result, '''', ''', [rfReplaceAll]);
end;
// 辅助函数：将字符串内容以UTF-8无BOM格式写入ZIP
procedure AddXmlToZip(Zip: TZipFile; const EntryName, Content: string);
var
Bytes: TBytes;
begin
Bytes := TEncoding.UTF8.GetBytes(Content);
Zip.Add(Bytes, EntryName, zcStored); //最快压缩速度
end;
begin
if FileExists(FileName) then
DeleteFile(FileName);
XMLData := TStringList.Create;
ZipFile := TZipFile.Create;
try
ZipFile.Open(FileName, zmWrite);
// 1. 写入 [Content_Types].xml
XMLData.Text := '<?xml version="1.0" encoding="UTF-8" standalone="yes"?>' +
'<Types xmlns="http://schemas.openxmlformats.org/package/2006/content-types">' +
'<Default Extension="rels" ContentType="application/vnd.openxmlformats-package.relationships+xml"/>' +
'<Default Extension="xml" ContentType="application/xml"/>' +
'<Override PartName="/xl/workbook.xml" ContentType="application/vnd.openxmlformats-officedocument.spreadsheetml.sheet.main+xml"/>' +
'<Override PartName="/xl/worksheets/sheet1.xml" ContentType="application/vnd.openxmlformats-officedocument.spreadsheetml.worksheet+xml"/>' +
'</Types>';
AddXmlToZip(ZipFile, '[Content_Types].xml', XMLData.Text);
// 2. 写入 _rels/.rels
XMLData.Text := '<?xml version="1.0" encoding="UTF-8" standalone="yes"?>' +
'<Relationships xmlns="http://schemas.openxmlformats.org/package/2006/relationships">' +
'<Relationship Id="rId1" Type="http://schemas.openxmlformats.org/officeDocument/2006/relationships/officeDocument" Target="xl/workbook.xml"/>' +
'</Relationships>';
AddXmlToZip(ZipFile, '_rels/.rels', XMLData.Text);
// 3. 写入 xl/workbook.xml
XMLData.Text := '<?xml version="1.0" encoding="UTF-8" standalone="yes"?>' +
'<workbook xmlns="http://schemas.openxmlformats.org/spreadsheetml/2006/main" xmlns:r="http://schemas.openxmlformats.org/officeDocument/2006/relationships">' +
'<sheets><sheet name="Sheet1" sheetId="1" r:id="rId1"/></sheets>' +
'</workbook>';
AddXmlToZip(ZipFile, 'xl/workbook.xml', XMLData.Text);
// 4. 写入 xl/_rels/workbook.xml.rels
XMLData.Text := '<?xml version="1.0" encoding="UTF-8" standalone="yes"?>' +
'<Relationships xmlns="http://schemas.openxmlformats.org/package/2006/relationships">' +
'<Relationship Id="rId1" Type="http://schemas.openxmlformats.org/officeDocument/2006/relationships/worksheet" Target="worksheets/sheet1.xml"/>' +
'</Relationships>';
AddXmlToZip(ZipFile, 'xl/_rels/workbook.xml.rels', XMLData.Text);
// ========================================================
// 5. 写入 xl/worksheets/sheet1.xml (包含列宽定义和数据)，使用内联字符串方式，省去共享字符串表的复杂度
// ========================================================
XMLData.Clear;
XMLData.Add('<?xml version="1.0" encoding="UTF-8" standalone="yes"?>');
XMLData.Add('<worksheet xmlns="http://schemas.openxmlformats.org/spreadsheetml/2006/main">');
// --- 写入列宽 <cols> 节点 ---
if Length(ColWidths) > 0 then
begin
XMLData.Add('<cols>');
for i := Low(ColWidths) to High(ColWidths) do
begin
// 确保不越界，且只处理有效宽度（大于0）
if (i < ADataSet.FieldCount) and (ColWidths[i] > 0) then
begin
// Excel的列号是从1开始的，所以是 i+1
// customWidth="1" 告诉Excel这是用户自定义宽度
XMLData.Add(Format('<col min="%d" max="%d" width="%s" customWidth="1"/>',
[i + 1, i + 1, FloatToStr(ColWidths[i], TFormatSettings.Invariant)]));
end;
end;
XMLData.Add('</cols>');
end;
XMLData.Add('<sheetData>');
RowIdx := 1;
ADataSet.DisableControls;
ABookMark := ADataSet.GetBookmark;
ADataSet.First;
// 写列头
if bWriteTitle then
begin
XMLData.Add(Format('<row r="%d">', [RowIdx]));
for ColIdx := 0 to ADataSet.FieldCount - 1 do
begin
XMLData.Add(Format('<c r="%s%d" t="inlineStr"><is><t>%s</t></is></c>',
[ColLetter(ColIdx), RowIdx, EscapeXML(ADataSet.Fields[ColIdx].DisplayLabel)]));
end;
XMLData.Add('</row>');
Inc(RowIdx);
end;
// 写数据集中的数据
while not ADataSet.Eof do
begin
XMLData.Add(Format('<row r="%d">', [RowIdx]));
for ColIdx := 0 to ADataSet.FieldCount - 1 do
begin
case ADataSet.Fields[ColIdx].DataType of
ftSmallint, ftInteger, ftWord, ftAutoInc, ftBytes, ftLargeint:
XMLData.Add(Format('<c r="%s%d"><v>%d</v></c>',
[ColLetter(ColIdx), RowIdx, ADataSet.Fields[ColIdx].AsInteger]));
ftFloat, ftCurrency, ftBCD, ftFMTBcd, ftExtended:
// 注意：Xlsx的XML标准要求数字的小数点必须是 '.' 而不能是本地化的 ','
XMLData.Add(Format('<c r="%s%d"><v>%s</v></c>',
[ColLetter(ColIdx), RowIdx, FloatToStr(ADataSet.Fields[ColIdx].AsFloat, TFormatSettings.Invariant)]));
else
// 字符串使用内联字符串 写入
XMLData.Add(Format('<c r="%s%d" t="inlineStr"><is><t>%s</t></is></c>',
[ColLetter(ColIdx), RowIdx, EscapeXML(ADataSet.Fields[ColIdx].AsString)]));
end;
end;
XMLData.Add('</row>');
Inc(RowIdx);
ADataSet.Next;
end;
if ADataSet.BookmarkValid(ABookMark) then
ADataSet.GotoBookmark(ABookMark);
ADataSet.EnableControls;
XMLData.Add('</sheetData>');
XMLData.Add('</worksheet>');
AddXmlToZip(ZipFile, 'xl/worksheets/sheet1.xml', XMLData.Text);
finally
ZipFile.Free;
XMLData.Free;
end;
end;
浙公网安备 33010602011771号