* sample invocation LOCAL ARRAY laHeader_Info[12,5] LOCAL lnI AS INTEGER SELECT * from Patients INTO CURSOR c_PlanCodes READWRITE LOCAL ARRAY laHeader_Info[12,5] LOCAL lnI AS INTEGER lnI = 1 laHeader_Info[lnI,1] = 'PT NUMBER' laHeader_Info[lnI,5] = 'TEXT' lnI = lnI + 1 laHeader_Info[lnI,1] = 'PATIENT NAME' laHeader_Info[lnI,5] = 'COUNT' lnI = lnI + 1 laHeader_Info[lnI,1] = 'ADM DT' lnI = lnI + 1 laHeader_Info[lnI,1] = 'DISCH DT' lnI = lnI + 1 laHeader_Info[lnI,1] = 'SVC' lnI = lnI + 1 laHeader_Info[lnI,1] = 'INS1' lnI = lnI + 1 laHeader_Info[lnI,1] = 'POLICY' lnI = lnI + 1 laHeader_Info[lnI,1] = 'INS1 NAME' lnI = lnI + 1 laHeader_Info[lnI,1] = 'ACCT BAL' laHeader_Info[lnI,5] = 'SUM' lnI = lnI + 1 laHeader_Info[lnI,1] = 'SUBSCRIBER' lnI = lnI + 1 laHeader_Info[lnI,1] = 'SOCIAL' lnI = lnI + 1 laHeader_Info[lnI,1] = 'COMMENTS' =MESSAGEBOX(DBFToExcel('C:\XLS_Files\' + tcPlan_code + '.XLS', ; @laHeader_Info, ALLTRIM(cCarrier_name) + ' - ' + tcPlan_code)) ENDFUNC ************************************************************ * FUNCTION DBFToExcel() ************************************************************ *) Description.......: Creates an Excel file from open table / cursor * Calling Samples...: DbfToExcel(m.lcXLSFile, @laHeader_Info, "Batch Statistics") * Parameter List....: tcXLSFileName, taHeader_Info, tcTitle, tcPassword, tlLockHeaderRow, * tlSetPrintSetup, tcReportTitle * Major change list.: FUNCTION DBFToExcel LPARAMETERS tcXLSFileName, taHeader_Info, tcTitle, tcPassword, tlLockHeaderRow, tlSetPrintSetup, tcReportTitle 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 lcDir lcDir = JUSTPATH(tcXLSFileName) IF NOT EMPTY(lcDir) IF NOT DIRECTORY(lcDir) RETURN "The directory " + lcDir + " doesn't properly set up. " + CRLF + ; "Please contact the system administrator." ENDIF 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 XL5 && Oddly Using TYPE XL5 produces the file in the upper case MoveFile(m.tcXLSFileName, m.tcXLSFileName) *-- 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 * Name the sheet loSheet.NAME = LEFT(StripBadCharsFromFile(laTitle[lnLines]),31) FOR lnK = 1 TO m.lnLines loSheet.Cells(m.lnK, 1).VALUE = laTitle[m.lnK] NEXT 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 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]) 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].SELECT *loRange.COLUMNS[m.lnK].NumberFormat = taHeader_Info[m.lnK,3] loExcel.SELECTION.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 ** Code by Gary W loExcel.COLUMNS("A:A").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 IF VARTYPE(tlSetPrintSetup) = 'L' AND tlSetPrintSetup = SetExcelPageSetup(loExcel, tcReportTitle) 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 Excel loExcel.ActiveWorkbook.PASSWORD = m.tcPassword && Works in Excel 2003 ENDIF IF '12' $ loExcel.VERSION && XL 2007 * Kevin Delaney's suggestion loExcel.ActiveWorkbook.SAVEAS(tcXLSFileName, 39) && 39 *loExcel.SAVE() * Cetin Basoz suggestion loExcel.ActiveWorkbook.Saved = .T. loExcel.ActiveWorkbook.CLOSE(0) ELSE loExcel.SAVE() ENDIF CATCH TO loError lcError = Log_Error(m.loError) FINALLY IF VARTYPE(m.loExcel) = 'O' loExcel.QUIT RELEASE loExcel ENDIF ENDTRY RETURN m.lcError ENDFUNC