Delphi 轉EXCEL 合併單元格解決方案
廢話少說先上傳程式碼,自己看吧!
procedure TForm1.Button10Click(Sender: TObject);
var
FExcel:Variant;
FWorkbook:Variant;
FWorkSheet:Variant;
XlsFileName:String;
i,j:Integer;
Field1,field2,Field3,Field4:string;
LastField1,LastField2,Lastfield3,LastField4:string;
savedailog:TSaveDialog;
begin
savedailog:=TSaveDialog.Create(Self);
savedailog.Filter:='Excel files (*.xls)|*.XlS';
if savedailog.Execute then begin
xlsfilename:=savedailog.FileName;
savedailog.Free;
end
else begin
savedailog.Free;
exit;
end;
screen.Cursor := crHourGlass;
Try
FExcel := CreateOleObject('Excel.application');
except
screen.Cursor:=crDefault;
ShowMessage('出錯!沒有安裝Excel軟體!');
exit;
end;
FExcel.DisplayAlerts :=false ; //不提示彈出對話方塊
try
FWorkbook :=FExcel.WorkBooks.Add;
DM.Q_FindProcess.First;
LastField1:='';
LastField2:='';
Lastfield3:='';
Lastfield4:='';
if DM.Q_FindProcess.RecordCount >0 then begin
//新增表頭
j:=1;
FExcel.cells[j,1]:='專案名稱';
FExcel.cells[j,2]:='產品名稱';
FExcel.cells[j,3]:='模具';
FExcel.cells[j,4]:='節點';
FExcel.cells[j,5]:='序號';
FExcel.cells[j,6]:='事項內容';
FExcel.cells[j,7]:='計劃日期';
FExcel.cells[j,8]:='實際日期';
FExcel.cells[j,9]:='狀態';
FExcel.cells[j,10]:='備註';
FExcel.cells[j,11]:='型別';
//新增表身
for i:=1 to DM.Q_FindProcess.RecordCount do begin
j:=i+1;
Field1:=DM.Q_FindProcessMainProjectName.AsString;
field2:=DM.Q_FindProcessSubProjectName.AsString;
field3:=DM.Q_FindProcessMouldName.AsString;
field4:=DM.Q_FindProcessProjectStatusName.AsString;
try
FExcel.cells[j,1]:=DM.Q_FindProcessMainProjectName.AsString;
FExcel.cells[j,2]:=DM.Q_FindProcessSubProjectName.AsString;
FExcel.cells[j,3]:=DM.Q_FindProcessMouldName.AsString;
FExcel.cells[j,4]:=DM.Q_FindProcessProjectStatusName.AsString;
FExcel.cells[j,5]:=DM.Q_FindProcessSeq.AsString;
FExcel.cells[j,6]:=DM.Q_FindProcessWorkContent.AsString;
FExcel.cells[j,7]:=DM.Q_FindProcessPlanDatePoint.AsString;
FExcel.cells[j,8]:=DM.Q_FindProcessActDatePoint.AsString;
FExcel.cells[j,9]:=DM.Q_FindProcessSubStatus.AsString;
FExcel.cells[j,10]:=DM.Q_FindProcessRemark.AsString;
FExcel.cells[j,11]:=DM.Q_FindProcessSubProjectType.AsString;
if Field1 = LastField1 then
FExcel.Range[FExcel.Cells[j-1,1],FExcel.Cells[j,1]].MergeCells:=True;
if Field2 = LastField2 then
FExcel.Range[FExcel.Cells[j-1,2],FExcel.Cells[j,2]].MergeCells:=True;
if Field3 = LastField3 then
FExcel.Range[FExcel.Cells[j-1,3],FExcel.Cells[j,3]].MergeCells:=True;
if Field4 = LastField4 then
FExcel.Range[FExcel.Cells[j-1,4],FExcel.Cells[j,4]].MergeCells:=True;
LastField1 := Field1;
LastField2 := Field2;
LastField3 := Field3;
LastField4 := Field4;
finally
FExcel.Visible := true;
Screen.Cursor := crDefault;
end;
DM.Q_FindProcess.Next;
end;
end;
FWorkSheet.saveas(xlsfilename);
FExcel.quit;
ShowMessage('輸出 Excel 檔案已完成。。。');
Except
ShowMessage('出錯!輸出檔案錯誤!');
FWorkBook.Close;
FExcel.Quit;
Exit;
end;
end;