以极简代码实现导出数据集到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, '&', '&amp;', [rfReplaceAll]);
    Result := StringReplace(Result, '<', '&lt;', [rfReplaceAll]);
    Result := StringReplace(Result, '>', '&gt;', [rfReplaceAll]);
    Result := StringReplace(Result, '"', '&quot;', [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;