问题已经解决，解决思路1、在delphi中放置EHlib控件，利用EHLIB的导出函数导出，数据较快。2、编写EXCEL模板，在面板里面写好VBA编码，3、在Delphi中编写函数 var excelobj, excelbook: variant;
applicationpath, runcommand, reportds, savefilename, excelpath: string;
Outresult: boolean;
begin
//---判断是否配置了数据源 [2009-1016添加判断] if trim(edit1.Text) = '' then
begin
application.MessageBox('提示', '系统管理员未设置导出报表数据源', 1 + 64);
abort;
end;
//--程序的路径 applicationpath := extractfilepath(Application.ExeName) + 'Excel/';
reportds := edit1.Text;
excelpath := applicationpath + reportds + '_module.xls';
//--判断模板文件是否存在 //--调用保存对话框 if EXCELSAVEDIA.Execute then
begin
savefilename := EXCELSAVEDIA.FileName end else
abort;
//--保存 SaveDBGridEhToExportFile(TDBGridEhExportAsXLS, EXCEL1, applicationpath + reportds + '.xls', True);
//--执行宏 excelobj := createoleobject('excel.application');
excelbook := excelobj.application.workbooks.add;
runcommand := reportds + '_module.xls!reportout';
try excelbook := excelobj.application.workbooks.open(excelpath);
//----把参数赋值给新建的EXCEL 工资本 excelbook.WorkSheets[2].Activate;
excelbook.WorkSheets[2].Cells[10, 1].Value := savefilename;
excelbook.WorkSheets[2].Cells[11, 1].Value := reportds;
excelbook.WorkSheets[2].Cells[12, 1].Value := applicationpath;
excelobj.application.run(runcommand);
excelbook.close(false);
except end;
//退出 excelobj.quit;
//--释放 excelobj := unassigned;
excelobj := unassigned;
application.MessageBox('导出成功', '提示', MB_OK);6、执行VBA后程序搞定贴上VBA的代码Sub Reportout() '''公用模块 begin
Dim savefilename As String '处理好文件的存储位置 Dim reportDS As String '报表数据源的编号 Dim applicationpath As String '程序的位置 Dim outexcelpath As String '程序Grid表格导出的位置 Dim lastrow As Integer Dim lastcolumn As Integer '限制第一个工作簿为MODULE1 第二个为 sheet1 Sheets("Sheet1").Select savefilename = Range("A10").Text reportDS = Range("A11").Text applicationpath = Range("A12").Text outexcelpath = Range("A12").Text & reportDS & ".xls" Sheets("Module1").Select Workbooks.Open filename:=outexcelpath '公用模块 END '选择并删除不需要的列 [手工设置 1、不需要的列] Range("A:A,B:B,C:C,G:G,H:H,K:K,L:L,M:M,O:O,Q:Q,R:R,S:S").Select Selection.Delete Shift:=xlToLeft '插入列 Columns("A:A").Select Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove '设置序号 Range("A2").Select ActiveCell.FormulaR1C1 = "1" Range("A3").Select ActiveCell.FormulaR1C1 = "2" Range("A2:A3").Select lastrow = ActiveSheet.UsedRange.Rows.Count If lastrow > 2 then
'2009-10-14调整 判断当行数小于2时候的报错 Selection.AutoFill Destination:=Range(Cells(2, 1), Cells(lastrow, 1)) End If '插入行 'Rows("1:1").Select 'Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove 'Rows("1:1").Select 'Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove 'Range("A1").Select '计算表头行数和列数 Windows(reportDS & "_module.xls").Activate Sheets("Module1").Select '{[手工设置表头的大小] } '2009-10-15调整成动态判断 lastrow = ActiveSheet.UsedRange.Rows.Count lastcolumn = ActiveSheet.UsedRange.Rows.Column '插入行 Windows(reportDS & ".xls").Activate Dim k As Integer k = 1 do
Range("1:1").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove k = k + 1 Loop Until k > lastrow '复制来源 Windows(reportDS & "_module.xls").Activate Range(Cells(1, 1), Cells(lastrow, lastcolumn)).Select Selection.Copy '粘贴 Windows(reportDS & ".xls").Activate Range("A1").Select ActiveSheet.Paste Rows("3:3").Select Application.CutCopyMode = False Selection.Delete Shift:=xlUp '列宽自动 Columns("A:A").EntireColumn.AutoFit Columns("B:B").EntireColumn.AutoFit Columns("E:E").EntireColumn.AutoFit Columns("F:F").EntireColumn.AutoFit Columns("G:G").EntireColumn.AutoFit Columns("H:H").EntireColumn.AutoFit Columns("I:I").EntireColumn.AutoFit Columns("J:J").EntireColumn.AutoFit Columns("B:B").ColumnWidth = 25 '设置标题 Range("A1:J1").Select Range("A1:J1").RowHeight = 40 Range("A2:J2").RowHeight = 25 ActiveCell.FormulaR1C1 = "（" & Year(Date) & "年" & Month(Date) & "月" & Day(Date) & "日） 成车库收发存报表" '设置分组 lastrow = ActiveSheet.UsedRange.Rows.Count Dim grouprange As Range Set grouprange = Range(Cells(2, 1), Cells(lastrow, 10)) grouprange.Subtotal GroupBy:=2, Function:=xlSum, TotalList:=Array(5, 6, 7, 8, _ 9, 10), Replace:=True, PageBreaks:=False, SummaryBelowData:=True '设置分组的颜色 lastrow = ActiveSheet.UsedRange.Rows.Count Dim i As Integer i = 3 do
If Cells(i, 1) = "" then
Range(Cells(i, 1), Cells(i, 10)).Select With Selection.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .ThemeColor = xlThemeColorAccent2 .TintAndShade = 0.799981688894314 .PatternTintAndShade = 0 End With End If i = i + 1 Loop Until i = lastrow '设置格式 Dim myrange As Range Dim myborders As Borders Set myrange = Range(Cells(3, 1), Cells(lastrow, 10)) Set myborders = myrange.Borders myborders.LineStyle = xlDouble myrange.Select myrange.Borders(xlDiagonalDown).LineStyle = xlNone myrange.Borders(xlDiagonalUp).LineStyle = xlNone With Selection.Borders(xlEdgeLeft) .LineStyle = xlContinuous .Color = -10477568 .TintAndShade = 0 .Weight = xlThick End With With Selection.Borders(xlEdgeTop) .LineStyle = xlDashDotDot .Color = -10477568 .TintAndShade = 0 .Weight = xlThin End With With Selection.Borders(xlEdgeBottom) .LineStyle = xlContinuous .Color = -10477568 .TintAndShade = 0 .Weight = xlThick End With With Selection.Borders(xlEdgeRight) .LineStyle = xlContinuous .Color = -10477568 .TintAndShade = 0 .Weight = xlThick End With With Selection.Borders(xlInsideVertical) .LineStyle = xlDashDotDot .ThemeColor = 4 .TintAndShade = 0.599963377788629 .Weight = xlThin End With With Selection.Borders(xlInsideHorizontal) .LineStyle = xlDashDotDot .ThemeColor = 4 .TintAndShade = 0.599963377788629 .Weight = xlThin End With '保存工作表 ActiveWorkbook.Application.DisplayAlerts = False ActiveWorkbook.SaveAs filename:=savefilename, _ FileFormat:=xlExcel8, Password:="", WriteResPassword:="", _ ReadOnlyRecommended:=False, CreateBackup:=False End Sub
][
][
][