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;