Question

delphi7导出excel的问题

代码如下
function TForm12.ToExcel(sfilename: string; ADOQuery: TADOQuery): boolean; //生成excelconst
xlNormal = -4143;
var
y: integer;
tsList: TStringList;
s, filename: string;
aSheet: Variant;
excel: OleVariant;
savedialog: tsavedialog;
begin
Result := true;
try
excel := CreateOleObject('Excel.Application');
excel.workbooks.add;
except
//screen.cursor:=crDefault;
showmessage('无法调用Excel！');
exit;
end;
savedialog := tsavedialog.Create(nil);
savedialog.FileName := sfilename; //存入文件
savedialog.Filter := 'Excel文件(*.xls)|*.xls';
if savedialog.Execute then
begin
if FileExists(savedialog.FileName) then
try
if application.messagebox('该文件已经存在，要覆盖吗？', '询问', mb_yesno + mb_iconquestion) = idyes then
DeleteFile(PChar(savedialog.FileName))
else
begin
Excel.Quit;
savedialog.free;
//screen.cursor:=crDefault;
Exit;
end;
except
Excel.Quit;
savedialog.free;
screen.cursor := crDefault;
Exit;
end;
filename := savedialog.FileName;
end;
savedialog.free;
if filename = '' then
begin
result := true;
Excel.Quit;
//screen.cursor:=crDefault;
exit;
end;
aSheet := excel.Worksheets.Item[1];
tsList := TStringList.Create;
//tsList.Add('查询结果'); //加入标题
s := ''; //加入字段名 for y := 0 to adoquery.fieldCount - 1 do
begin
s := s + adoQuery.Fields.Fields[y].FieldName + #9;
Application.ProcessMessages;
end;
tsList.Add(s);
try
try
ADOQuery.First;
while not ADOQuery.Eof do
begin
s := '';
for y := 0 to ADOQuery.FieldCount - 1 do
begin
s := s + ADOQuery.Fields[y].AsString + #9;
Application.ProcessMessages;
end;
tsList.Add(s);
ADOQuery.next; end;
Clipboard.AsText := tsList.Text;
except
result := false;
end;
finally
tsList.Free;
end;
aSheet.Paste;
MessageBox(Application.Handle, '数据导出完毕！', '系统提示', MB_ICONINFORMATION or MB_OK);
try
if copy(FileName, length(FileName) - 3, 4) <> '.xls' then
FileName := FileName + '.xls';
Excel.ActiveWorkbook.SaveAs(FileName, xlNormal, '', '', False, False);
except
Excel.Quit;
screen.cursor := crDefault;
exit;
end;
Excel.Visible := false; //true会自动打开已经保存的excel
Excel.Quit;
Excel := UnAssigned;
end;

短点的内容还好，长点的就成这样了，怎么解决啊？！！（不要看马赛克，看下面的）

Answer 1

我觉得你这种用list方式导Excel，造成你导出的问题，因为里面有换行符号。我一般都用以下代码转Excel，你可以试试！

procedure TForm_main.btn_excelClick(Sender: TObject);
var
XL: Variant; //打开EXCEL文件的Variant变量
Sheet: Variant;//指向EXCEL表单的Variant变量
Range: Variant;
RecNo,I: Integer;//记录数据表的当前记录号
begin
if dlgSave1.Execute then
begin
XL := CreateOleObject('Excel.Application');
XL.Visible := true;
XL.WorkBooks.Add;
XL.WorkBooks[XL.WorkBooks.Count].WorkSheets[1].Name := 'test';
Sheet := XL.WorkBooks[XL.WorkBooks.Count].WorkSheets[Trim('test')];
RecNo := 1;

//填充表标题
for I:=0 to DBGridEh1.Columns.Count-1 do //初始化行，定位在第一 行
if DBGridEh1.Columns[I].Visible then
begin
Sheet.Cells.item[1, I+1] := DBGridEh1.Columns[I].Title.Caption; //.DisplayLabel;
Sheet.Cells[1, I+1].Borders.LineStyle:=1//加边框
end;
Sheet.rows[3].font.size:=12;

//填充数据
cds_bom.First;
while not cds_bom.Eof do
begin
for I := 0 to DBGridEh1.Columns.Count - 1 do
begin
if DBGridEh1.Columns[I].Visible then
begin
Sheet.Cells.Item[RecNo+1,I+1]:=
cds_bom.fieldbyname(DBGridEh1.Columns[I].FieldName).AsString; //［行，列］
Sheet.Cells[RecNo+1,I+1].Borders.LineStyle:=1//加边框
end;
end;

//各类标记 行着色
if cds_bom.fieldbyname('general_tag').AsString='T' then
begin
Range:=XL.Range[sheet.cells[RecNo+1,1],sheet.cells[RecNo+1,DBGridEh1.Columns.Count]];
Range.Interior.Color:=checkbox_3.Font.Color;
end;

if cds_bom.fieldbyname('standard_tag').AsString='T' then
begin
Range:=XL.Range[sheet.cells[RecNo+1,1],sheet.cells[RecNo+1,DBGridEh1.Columns.Count]];
Range.Interior.Color:=checkbox_4.Font.Color;
end;

if cds_bom.fieldbyname('cable_tag').AsString='T' then
begin
Range:=XL.Range[sheet.cells[RecNo+1,1],sheet.cells[RecNo+1,DBGridEh1.Columns.Count]];
Range.Interior.Color:=checkbox_6.Font.Color;
end;

if cds_bom.fieldbyname('chemical_tag').AsString='T' then
begin
Range:=XL.Range[sheet.cells[RecNo+1,1],sheet.cells[RecNo+1,DBGridEh1.Columns.Count]];
Range.Interior.Color:=checkbox_7.Font.Color;
end;

if cds_bom.fieldbyname('user1_tag').AsString='T' then
begin
Range:=XL.Range[sheet.cells[RecNo+1,1],sheet.cells[RecNo+1,DBGridEh1.Columns.Count]];
Range.Interior.Color:=checkbox_8.Font.Color;
end;

if cds_bom.fieldbyname('user2_tag').AsString='T' then
begin
Range:=XL.Range[sheet.cells[RecNo+1,1],sheet.cells[RecNo+1,DBGridEh1.Columns.Count]];
Range.Interior.Color:=checkbox_9.Font.Color;
end;

if cds_bom.fieldbyname('user3_tag').AsString='T' then
begin
Range:=XL.Range[sheet.cells[RecNo+1,1],sheet.cells[RecNo+1,DBGridEh1.Columns.Count]];
Range.Interior.Color:=checkbox_10.Font.Color;
end;

Sheet.rows[RecNo].font.size:=12;
Inc(RecNo);
cds_bom.Next;
end;

//底部颜色注释
Sheet.Cells[RecNo+3,1].Interior.Color:=checkbox_3.Font.Color;
Sheet.Cells.item[RecNo+3, 2] :=checkbox_3.Caption;
Sheet.Cells[RecNo+4,1].Interior.Color:=checkbox_4.Font.Color;
Sheet.Cells.item[RecNo+4, 2] :=checkbox_4.Caption;
Sheet.Cells[RecNo+5,1].Interior.Color:=checkbox_6.Font.Color;
Sheet.Cells.item[RecNo+5, 2] :=checkbox_6.Caption;
Sheet.Cells[RecNo+6,1].Interior.Color:=checkbox_7.Font.Color;
Sheet.Cells.item[RecNo+6, 2] :=checkbox_7.Caption;
Sheet.Cells[RecNo+7,1].Interior.Color:=checkbox_8.Font.Color;
Sheet.Cells.item[RecNo+7, 2] :=checkbox_8.Caption;
Sheet.Cells[RecNo+8,1].Interior.Color:=checkbox_9.Font.Color;
Sheet.Cells.item[RecNo+8, 2] :=checkbox_9.Caption;
Sheet.Cells[RecNo+9,1].Interior.Color:=checkbox_10.Font.Color;
Sheet.Cells.item[RecNo+9, 2] :=checkbox_10.Caption;

try
XL.WorkBooks[XL.WorkBooks.Count].SaveAs(dlgSave1.FileName);
except ;
end;
end;
end;

Answer 2

那是单元格格式的问题
你设置单元格格式为自动换行即可。

Answer 3

你可以先判断所有列中数据最长的长度是多少，然后设置excel该列的最大长度，就没有这种问题了。

追问

不会，具体要改哪个地方，能给个代码吗

追答

设置某列宽度的具体方法我忘了，我也是5年前做这样的开发了。你可以上一些Delphi开发论坛找找看。

Answer 4

list控件显示的数据好像不能直接导出到excel，你可以做一个查询，然后直接导出到Excel(好像是用‘另存为’）,如果你要保存在已有的Excel文档，用复制粘贴好了，也挺方便的。