导出到EXCEL，TEXT

var
  frmSendJindu: TfrmSendJindu;
  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);

implementation

================================================================================

procedure  TfrmSendJindu.Daochufile;
var
  f:textfile;
  FstrPath,outstr:string;          //MSG是信息内容
  i,j:integer;
begin    //5
if SaveDialog1.Execute then
  begin    //4
     FstrPath:=SaveDialog1.FileName;
      if FstrPath<>'' then
      begin
       try   //1  finally
            Screen.Cursor:=crHourGlass;
            try  //  except
            if SaveDialog1.FilterIndex=1 then   //文本导出
            begin          //文本导出begin
            try             //finally   释放文件F
             if rightstr(FstrPath,4)<>'.txt' then
                FstrPath:=FstrPath+'.txt';
                AssignFile(F,FstrPath);     //创建文件
                Rewrite(F) ;       // 开始写写文件
                  if (plist.Count > 0) then
                  begin
                  //   if PageControl1.ActivePageIndex=2 then
                  //   begin
                  //   Writeln(f,'----总共 '+inttostr(plist.count)+' 条信息  ');
                  //   end
                 //    else
                     Writeln(f,'----总共 '+inttostr(plist.count)+' 条信息  ');
                     for i :=0 to plist.Count - 1 do
                        begin
                           outstr :=plist[i];
                           if StatusList[i] = '*0' then
                              outstr :=outstr+' ,'+'未发'
                           else if StatusList[i] = '*1' then
                              outstr :=outstr+' ,'+'发送成功'
                           else if StatusList[i] = '0' then
                              outstr :=outstr+' ,'+'接收成功'
                           else if StatusList[i] = '#' then
                              outstr :=outstr+' ,'+'发送成功'
                           else if leftstr(StatusList[i],1)= '*' then
                              outstr :=outstr+' ,'+'发送失败'
                           else
                              outstr :=outstr+' ,'+'接收失败';
                              outstr :=outstr+' ,'+msgList[i];
                              Writeln(f,outstr);
                        end;
                 end;
               finally     //finally   释放文件F
                 Flush(F);
                 CloseFile(F);
                 end;
           end          //文本导出end
          
           else begin                //EXCEL导出 begin
              if rightstr(FstrPath,4)<>'.xls' then
                 FstrPath:=FstrPath+'.xls';
                 if plist.count>65530 then
                 begin
                 ShowMessage('导出信息量过大，EXCEL无法正确导出。请选择用.txt方式导出');
                 exit;
                 end;
                ExportExcelFile(FstrPath,true);     //流文件写入EXCELL
             end;  //EXCEL导出 end;
             messagebox(self.Handle,pchar('导出成功！         总共'+inttostr(plist.count)+'条信息'+#13#10+'保存位置'+#13#10+FstrPath),'提示',mb_ok or MB_ICONQUESTION);
        except          //  except
            ShowMessage('不能正确导出文件，系统错误。');
            end;
        finally     //1  finally end
                 Screen.Cursor:=crDefault;
        end;
      end;
   end;
end;
==============================================================================

//这个是快速的直接写文件导出，无法对单元格操作

procedure TfrmSendJindu.ExportExcelFile(FileName: string;bWriteTitle: Boolean);
var
i, j: integer;
Col, row: word;
aFileStream: TFileStream;
procedure incColRow; //增加行列号
begin
if Col = 2 then
begin
    Inc(Row);
    Col :=0;
end
else
Inc(Col);
end;
procedure WriteStringCell(AValue: string);//写字符串数据
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(FileName); //文件存在，先删除
aFileStream := TFileStream.Create(FileName, fmCreate);
Try
//写文件头
aFileStream.WriteBuffer(arXlsBegin, SizeOf(arXlsBegin));
//写列头
Col := 0; Row := 0;
if bWriteTitle then
begin
WriteStringCell('  电话号码  ');
WriteStringCell('  状态 ');
WriteStringCell('    信     息    ');
end;
//写数据集中的数据
//ProgressBar1.Max := plist.Count;
for i := 0 to plist.Count - 1 do
begin
WriteStringCell(plist[i]);
              if StatusList[i] = '*0' then
                  WriteStringCell('未发')
               else if StatusList[i] = '*1' then
                 WriteStringCell('发送成功')
               else if StatusList[i] = '0' then
                 WriteStringCell('接收成功')
               else if StatusList[i] = '#' then
                 WriteStringCell('发送成功')
               else if leftstr(StatusList[i],1)= '*' then
                 WriteStringCell('发送失败')
               else
                 WriteStringCell('接收失败');
WriteStringCell(msglist[i]);
application.ProcessMessages;
//ProgressBar1.Position := ProgressBar1.Position+1;
end;
//ProgressBar1.Max := 0;
//写文件尾
AFileStream.WriteBuffer(arXlsEnd, SizeOf(arXlsEnd));
Finally
AFileStream.Free;
end;
end;

=======================================================

function ExportExcelFile(FileName: string; aDataSet: TDataSet): Boolean; //导出到EXCEL
var
  eclApp, WorkBook: olevariant;
  xlsFileName: string;
  i, j: integer;
  dbgrid1: TDBGrid;
  ds1: TDataSource;
begin
  result := False;
  try
    eclApp := CreateOleObject('Excel.Application');
    WorkBook := CreateOleObject('Excel.Sheet');
  except
    Exit;
  end;
  if FileExists(FileName) then DeleteFile(FileName); //文件存在，先删除
  try
    dbgrid1 := TDBGrid.Create(nil);
    ds1 := TDataSource.Create(nil);
    ds1.DataSet := aDataSet;
    dbgrid1.DataSource := ds1;
    WorkBook := eclApp.workbooks.Add;
    for i := 0 to DBGrid1.Columns.Count - 1 do
    begin
      eclApp.Cells(1, i + 1) := DBGrid1.Columns[i].FieldName;
    end;
    DBGrid1.DataSource.DataSet.First;
    j := 2;
    while not DBGrid1.DataSource.DataSet.Eof do
    begin
      for i := 0 to DBGrid1.DataSource.DataSet.FieldCount - 1 do
      begin
        eclApp.Cells(j, i + 1) := DBGrid1.DataSource.DataSet.Fields[i].AsString;
      end;
      DBGrid1.DataSource.DataSet.Next;
      inc(j);
    end;
    WorkBook.SaveAS(FileName);
  except
    Exit;
  end;
  WorkBook.close;
  eclApp.Quit;
  if Assigned(dbgrid1) then dbgrid1.Free;
  if Assigned(ds1) then ds1.Free;
  result := True;
end;