Copying a numeric value with decimals from a cursor into excel without rounding up

function VariableToExcel(Content, FieldType, CellReference)

local Success
Success = TRUE

local x, FormatMask

FieldType = iif(empty(m.FieldType), vartype(m.Content), m.FieldType)
x = null

do case
case isnull(m.Content)

case inlist(m.FieldType, T_CHARACTER, T_MEMO)
x = ['] + rtrim(m.Content)

case inlist(m.FieldType, T_DATE)
x = iif(empty(m.Content), '', '=date(' + transform(dtos(m.Content), '@R 9999,99,99') + ')')
FormatMask = 'dd/mm/yyyy'

case inlist(m.FieldType, T_DATETIME)
x = ;
iif(empty(m.Content), ;
'', ;
'=date(' + transform(dtos(m.Content), '@R 9999,99,99') + ')' ;
+ '+time(' + transform(right(ttoc(m.Content,1),6), '@R 99,99,99') + ')' ;
)
FormatMask = 'dd/mm/yyyy hh:mm:ss'

case inlist(m.FieldType, T_CURRENCY)
x = m.Content
FormatMask = '#,###.00' + '_);[Red](' + '#,###.00' + ')'

case inlist(m.FieldType, 'I')
x = m.Content
FormatMask = '#,###' + '_);[Red](' + '#,###' + ')'

case inlist(m.FieldType, T_NUMERIC, T_DOUBLE)
x = m.Content
FormatMask = '#,###.00' + '_);[Red](' + '#,###.00' + ')'

case inlist(m.FieldType, T_LOGICAL)
x = iif(m.Content, 'TRUE', 'FALSE')

endcase

do case
case (vartype(m.CellReference) <> T_OBJECT)
Success = FALSE

case isnull(m.x)
x = ''

otherwise
with m.CellReference
.Value = m.x

if( !empty(m.FormatMask) )
.NumberFormat = m.FormatMask
endif
endwith
endcase

return m.Success
endfunc
*--------------------------------------------------------------------------

************************************************************
* FUNCTION DBFToExcel()
************************************************************
* Author............: Nadya Nosonovsky
*) 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

** Make 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