>************************************************************ >* 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 >* Major change list.: >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 >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 > *-- 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 > > *!* 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 > > 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 > 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 > WITH .BORDERS(xlInsideVertical) > .LineStyle = xlContinuous > .Weight = xlThin > .ColorIndex = xlAutomatic > ENDWITH > 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) > > 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 >