FUNCTION DBFToExcel LPARAMETERS tcXLSFileName, taHeader_Info, tcTitle, tcPassword, tlLockHeaderRow EXTERNAL ARRAY taHeader_Info * This function assumes, that the output table (cursor) is currently opened *-- Generate output to XLS File * -- Do some basic parameter checking IF EMPTY(ALIAS()) RETURN "No table/cursor is currently opened to process." ENDIF IF EMPTY(m.tcXLSFileName) RETURN "Excel file name is not passed." ENDIF IF TYPE("taHeader_Info[1]") <> "C" RETURN "Array taHeader_Info is not passed." ENDIF IF VARTYPE(m.tcTitle) <> "C" RETURN "Excel title is not passed." ENDIF LOCAL loExcel, lnI, loSheet, lnK, lcError, lnLines, ; lnActualFields, lnHeaderCells, lcRange, lcStart, lcEnd, lnCols, lnOffset, ; lnTotalRows, lcStartRow, lcEndRow lcError = "" LOCAL ARRAY laTitle[1] IF NOT EMPTY(m.tcTitle) lnLines = ALINES(laTitle, m.tcTitle) lnOffset = 2 ELSE lnLines = 0 lnOffset = 1 ENDIF #include Excel.h #DEFINE xlPart 2 TRY lnActualFields = FCOUNT() lnHeaderCells = ALEN(taHeader_Info,1) COPY TO (m.tcXLSFileName) TYPE XLS *-- Create Ole Automation with Excel loExcel = CREATEOBJECT("Excel.Application") *-- Open XLS File loExcel.APPLICATION.WorkBooks.OPEN(m.tcXLSFileName) loExcel.DisplayAlerts = .F. FOR lnI = 1 TO loExcel.APPLICATION.APPLICATION.WorkBooks(1).Sheets.COUNT *-- Select individual sheets from open XLS File loSheet = loExcel.APPLICATION.APPLICATION.WorkBooks(1).Sheets(m.lnI) ** Delete the column headers from Excel (first row) loSheet.ROWS("1").DELETE(xlShiftDown) ** Insert lines with Title + 1 or 2 empty rows for the column headers loSheet.ROWS("1:" + ALLTRIM(STR(m.lnLines + m.lnOffset))).INSERT(xlShiftDown) IF m.lnLines > 0 && Title font WITH loSheet.RANGE("1:" + ALLTRIM(STR(m.lnLines))).FONT .COLOR = 8388736 && rgb(255,0,0) .SIZE = 14 .Bold = .T. .NAME = 'Tahoma' ENDWITH ENDIF ** Header font WITH loSheet.RANGE(ALLTRIM(STR(m.lnLines + 1)) + ; ":" + ALLTRIM(STR(m.lnLines + m.lnOffset))).FONT * .Color = Rgb(255,0,0) .SIZE = 11 .Bold = .T. .NAME = 'Tahoma' ENDWITH lnCols = m.lnHeaderCells lcEnd = IIF(m.lnCols > 26, CHR(INT((m.lnCols - 1) / 26) + 64), "") + ; CHR(((m.lnCols - 1) % 26) + 65) lcRange = "A1:" + m.lcEnd + ALLTRIM(STR(m.lnLines)) loSheet.RANGE(lcRange).SELECT WITH loExcel.SELECTION .HorizontalAlignment = xlCenter .VerticalAlignment = xlBottom .WrapText = .F. .ORIENTATION = 0 .AddIndent = .F. .IndentLevel = 0 .ShrinkToFit = .F. .ReadingOrder = xlContext .MergeCells = .T. ENDWITH *!* With loSheet.Range("1:2").Borders *!* .Weight = xlMedium *!* .LineStyle = xlContinuous *!* Endwith FOR lnK = 1 TO m.lnLines loSheet.Cells(m.lnK, 1).VALUE = laTitle[m.lnK] NEXT lnTotalRows = loSheet.UsedRange.ROWS.COUNT FOR lnK = 1 TO m.lnHeaderCells loSheet.Cells(m.lnOffset + m.lnLines, m.lnK).VALUE = ; taHeader_Info[m.lnK,1] + ; IIF(EMPTY(taHeader_Info[m.lnK,2]), "", ; CHR(10) + taHeader_Info[m.lnK,2]) * loSheet.Cells(3 + m.lnLines,m.lnK).value = taHeader_Info[m.lnK,2] IF !EMPTY(taHeader_Info[m.lnK,3]) && There is format information loRange = loSheet.UsedRange.Offset(m.lnLines + m.lnOffset) && we don't want to apply format for header rows loRange.COLUMNS[m.lnK].NumberFormat = taHeader_Info[m.lnK,3] ENDIF IF !EMPTY(taHeader_Info[m.lnK,4]) && There is Column Width loSheet.COLUMNS[m.lnK].SELECT loSheet.COLUMNS[m.lnK].COLUMNWIDTH = taHeader_Info[m.lnK,4] ELSE loSheet.COLUMNS[m.lnK].AUTOFIT() ENDIF IF TYPE("taHeader_Info[m.lnK,5]")="C" AND !EMPTY(taHeader_Info[m.lnK,5]) && There is a formula or text cell lcEnd = IIF(m.lnK > 26, CHR(INT((m.lnK - 1) / 26) + 64), "") + ; CHR(((m.lnK - 1) % 26) + 65) lcStartRow = ALLTRIM(STR(m.lnLines + m.lnOffset + 1)) lcEndRow = ALLTRIM(STR(m.lnTotalRows)) DO CASE CASE taHeader_Info[m.lnK,5] = "TEXT" loSheet.Cells(lnTotalRows + 2,m.lnK).VALUE = "TOTALS:" loSheet.Cells(lnTotalRows + 2,m.lnK).FONT.Bold = .T. loSheet.Cells(lnTotalRows + 2,m.lnK).FONT.NAME = 'Tahoma' CASE taHeader_Info[m.lnK,5] ="SUM" loSheet.Cells(lnTotalRows + 2,m.lnK).formula = "=SUM(" + lcEnd + lcStartRow + ":" + lcEnd + lcEndRow + ")" IF !EMPTY(taHeader_Info[m.lnK,3]) && There is format information loSheet.Cells(lnTotalRows + 2,m.lnK).NumberFormat = taHeader_Info[m.lnK,3] ENDIF CASE taHeader_Info[m.lnK,5] ="COUNT" loSheet.Cells(lnTotalRows + 2,m.lnK).formula = "=COUNTA(" + lcEnd + lcStartRow + ":" + lcEnd + lcEndRow + ")" IF !EMPTY(taHeader_Info[m.lnK,3]) && There is format information loSheet.Cells(lnTotalRows + 2,m.lnK).NumberFormat = taHeader_Info[m.lnK,3] ENDIF ENDCASE ENDIF NEXT NEXT IF m.lnHeaderCells > m.lnActualFields lnCols = m.lnActualFields + 1 ** Code from Sergey Berezniker lcStart = IIF(m.lnCols>26, CHR(INT((m.lnCols - 1) / 26) + 64), "") + ; CHR(((m.lnCols - 1) % 26) + 65) lnCols = m.lnHeaderCells lcEnd = IIF(m.lnCols > 26, CHR(INT((m.lnCols - 1) / 26) + 64), "") + ; CHR(((m.lnCols - 1) % 26) + 65) lcRange = m.lcStart + ALLTRIM(STR(m.lnLines + m.lnOffset)) + ":" + ; M.lcEnd + ALLTRIM(STR(m.lnLines + m.lnOffset)) WITH loSheet.RANGE(m.lcRange).Interior .ColorIndex = 33 && Blue Color .PATTERN = xlSolid .PatternColorIndex = xlAutomatic ENDWITH ELSE lnCols = m.lnActualFields lcEnd = IIF(m.lnCols > 26, CHR(INT((m.lnCols - 1) / 26) + 64), "") + ; CHR(((m.lnCols - 1) % 26) + 65) ENDIF ** Made the Totals row in bold and Green highlight loExcel.RANGE([A1], loExcel.SELECTION.SpecialCells(xlLastCell)).SELECT loExcel.SELECTION.FormatConditions.DELETE loExcel.SELECTION.FormatConditions.ADD(xlExpression,, '=UPPER(Left($A1,5))="TOTAL"') WITH loExcel.SELECTION.FormatConditions(1) .FONT.Bold = .T. .Interior.ColorIndex = 4 ENDWITH ** Now apply borders to each header cell lcRange = "A" + ALLTRIM(STR(m.lnLines + m.lnOffset)) + ":" + ; M.lcEnd + ALLTRIM(STR(m.lnLines + m.lnOffset)) WITH loSheet.RANGE(m.lcRange) WITH .BORDERS(xlEdgeLeft) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic ENDWITH WITH .BORDERS(xlEdgeTop) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic ENDWITH WITH .BORDERS(xlEdgeBottom) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic ENDWITH WITH .BORDERS(xlEdgeRight) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic ENDWITH IF ALEN(taHeader_Info,1) > 1 WITH .BORDERS(xlInsideVertical) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic ENDWITH ENDIF ENDWITH IF m.tlLockHeaderRow && we need to prevent headers from modifying ** Code from Borislav Borissov loSheet.UsedRange.SELECT loExcel.SELECTION.Locked = .F. && First we need to UNLOCK all cells loExcel.ROWS(m.lnLines + m.lnOffset).SELECT && Select the header row of the sheet loExcel.SELECTION.Locked = .T. && Lock Cells in the header row loExcel.ActiveWorkbook.ActiveSheet.PROTECT(,.T.,,.T.) ENDIF loExcel.RANGE([A1]).SELECT && So we would not end up with whole file selected IF NOT EMPTY(m.tcPassword) ** Works in newer versions of Word loExcel.ActiveWorkbook.PASSWORD = m.tcPassword && Works in Excel 2003 ENDIF loExcel.SAVE() CATCH TO loError lcError = Log_Error(m.loError) FINALLY IF VARTYPE(m.loExcel) = 'O' loExcel.QUIT RELEASE loExcel ENDIF ENDTRY RETURN m.lcError ENDFUNC