Code: Alles auswählen
FUNC CopyToXls( cFile, aFieldNames, bFor, bWhile, nNext, aHeader, aColWidth, aTotal, aEmptyNumber, aFooter, lStart )
LOCAL aSource, aFieldPos, nCount, nRecords, i := 0
LOCAL aStyleNumber, aStyleDate, aStyleFields, aStyleFooter, aStyleHeader
LOCAL nFile, xField, cType, cValue, aFieldHeader
IF Valtype( aFieldNames ) <> "A"
aFieldNames := {}
ENDIF
IF nNext == NIL
nNext := LastRec()
ENDIF
aStyleNumber := { "s21", "Right", "Standard" }
aStyleDate := { "s22", "Center", "Short Date" }
aStyleFields := { "s31", "#FFFF99", "Solid" }
aStyleHeader := { "s41", "#0000FF", "1" }
aStyleFooter := { "s42", "#0000FF", "6" }
aSource := DbStruct()
IF Len( aFieldNames ) == 0
nCount := Len( aSource )
aFieldPos := Array( nCount )
WHILE ++i <= nCount
AAdd( aFieldNames, FieldName( i ) )
aFieldPos[i] := i
ENDDO
ELSE
nCount := Len( aFieldNames )
aFieldPos := Array( nCount )
WHILE ++i <= nCount
aFieldPos[i] := FieldPos( aFieldNames[i] )
ENDDO
ENDIF
IF aFooter == NIL
aFooter := { "" }
ENDIF
nFile := FCreate( cFile )
IF nFile == -1
RETURN NIL
ENDIF
FWrite( nFile,;
'<?xml version="1.0" encoding="windows-1252"?>'+CRLF+;
'<?mso-application progid="Excel.Sheet"?>'+CRLF+;
'<Workbook xmlns="urn:schemas-microsoft-com:office:spreadsheet"'+CRLF+;
' xmlns:o="urn:schemas-microsoft-com:office:office"'+CRLF+;
' xmlns:x="urn:schemas-microsoft-com:office:excel"'+CRLF+;
' xmlns:ss="urn:schemas-microsoft-com:office:spreadsheet"'+CRLF+;
' xmlns:html="http://www.w3.org/TR/REC-html40">'+CRLF )
FWrite( nFile,;
' <Styles>'+CRLF+;
' <Style ss:ID="Default" ss:Name="Normal">'+CRLF+;
' <Alignment ss:Vertical="Bottom"/>'+CRLF+;
' <Borders/>'+CRLF+;
' <Font/>'+CRLF+;
' <Interior/>'+CRLF+;
' <NumberFormat/>'+CRLF+;
' <Protection/>'+CRLF+;
' </Style>'+CRLF+;
' <Style ss:ID="'+aStyleNumber[1]+'">'+CRLF+;
' <Alignment ss:Horizontal="'+aStyleNumber[2]+'"/>'+CRLF+;
' <NumberFormat ss:Format="'+aStyleNumber[3]+'"/>'+CRLF+;
' </Style>'+CRLF+;
' <Style ss:ID="'+aStyleDate[1]+'">'+CRLF+;
' <Alignment ss:Horizontal="'+aStyleDate[2]+'"/>'+CRLF+;
' <NumberFormat ss:Format="'+aStyleDate[3]+'"/>'+CRLF+;
' </Style>'+CRLF+;
' <Style ss:ID="'+aStyleFields[1]+'">'+CRLF+;
' <Interior ss:Color="'+aStyleFields[2]+'" ss:Pattern="'+aStyleFields[3]+'"/>'+CRLF+;
' </Style>'+CRLF+;
' <Style ss:ID="'+aStyleHeader[1]+'">'+CRLF+;
' <Font ss:Color="'+aStyleHeader[2]+'" ss:Bold="'+aStyleHeader[3]+'"/>'+CRLF+;
' </Style>'+CRLF+;
' <Style ss:ID="'+aStyleFooter[1]+'">'+CRLF+;
' <Font ss:Size="'+aStyleFooter[3]+'" ss:Color="'+aStyleFooter[2]+'"/>'+CRLF+;
' </Style>'+CRLF+;
' </Styles>'+CRLF )
FWrite( nFile,;
' <Worksheet ss:Name="Folha1">'+CRLF+;
' <Table>'+CRLF )
IF ValType( aColWidth ) == "A"
FOR i := 1 TO Len( aColWidth )
cType := ValType( FieldGet( aFieldPos[i] ) )
FWrite( nFile,;
' <Column '+IIf(cType=="N",'ss:StyleID="'+aStyleNumber[1]+'" ',IIf(cType=="D",'ss:StyleID="'+aStyleDate[1]+'" ',''))+;
IIf(aColWidth[i]==NIL,'','ss:Width="'+LTrim(Str(aColWidth[i]))+'"')+'/>'+CRLF )
NEXT
ENDIF
IF ValType( aHeader ) == "A"
FOR i := 1 TO Len(aHeader)
IF ValType( aHeader[i] ) == "C"
FWrite( nFile,;
' <Row ss:StyleID="'+aStyleHeader[1]+'">'+CRLF+;
' <Cell><Data ss:Type="String">'+XmlEncode(ConvToAnsiCP(aHeader[i]))+'</Data></Cell>'+CRLF+;
' </Row>'+CRLF )
ELSE
aFieldHeader := aHeader[i]
ENDIF
NEXT
FWrite( nFile,; // Blank line
' <Row>'+CRLF+;
' </Row>'+CRLF )
ENDIF
FWrite( nFile, ' <Row'+IIf(Empty(aStyleFields),'',' ss:StyleID="'+aStyleFields[1]+'"')+'>'+CRLF )
IF aFieldHeader == NIL
aFieldHeader := aFieldNames
ENDIF
FOR i := 1 TO nCount
FWrite( nFile, ' <Cell><Data ss:Type="String">'+ConvToAnsiCP(aFieldHeader[i])+'</Data></Cell>'+CRLF )
NEXT
nRecords := 0
FWrite( nFile, ' </Row>'+CRLF )
WHILE !EOF() .AND. nRecords <= nNext .AND. ( bWhile == NIL .OR. EVal( bWhile ) )
IF bFor == NIL .OR. EVal( bFor )
FWrite( nFile, ' <Row>'+CRLF )
FOR i := 1 TO nCount
xField := FieldGet( aFieldPos[i] )
cType := ValType( xField )
DO CASE
CASE cType == "C"
cType := "String"
cValue := XmlEncode( ConvToAnsiCP( xField ) )
CASE cType == "N"
IF xField <> 0.0 .OR. aEmptyNumber == NIL .OR. AScan( aEmptyNumber, i ) == 0
cType := "Number"
cValue := LTrim( Str( xField ) )
ELSE
cType := "String"
cValue := ""
ENDIF
CASE cType == "D"
cValue := DToS( xField )
IF Empty( cValue )
cType := "String"
cValue := ""
ELSE
cType := "DateTime"
cValue := Substr(cValue,1,4)+"-"+Substr(cValue,5,2)+"-"+Substr(cValue,7,2)+"T00:00:00.000"
ENDIF
CASE cType == "L"
cType := "String"
cValue := IIf( xField, "T", "F" )
OTHERWISE
cType := "String"
cValue := "#ERRO#"
ENDCASE
FWrite( nFile, ' <Cell><Data ss:Type="'+cType+'">'+cValue+'</Data></Cell>'+CRLF )
NEXT
++nRecords
FWrite( nFile, ' </Row>'+CRLF )
ENDIF
DbSkip()
ENDDO
IF ValType( aTotal ) == "A"
FWrite( nFile,;
' <Row>'+CRLF+;
' <Cell><Data ss:Type="String"></Data></Cell>'+CRLF+;
' </Row>'+CRLF )
++nRecords
FWrite( nFile, ' <Row>'+CRLF )
FOR i := 1 TO Len( aTotal )
FWrite( nFile, ' <Cell ss:Index="'+LTrim(Str(aTotal[i]))+;
'" ss:Formula="=SUM(R[-'+LTrim(Str(nRecords))+']C:R[-2]C)"></Cell>'+CRLF )
NEXT
FWrite( nFile, ' </Row>'+CRLF )
ENDIF
FWrite( nFile,; // Blank line
' <Row>'+CRLF+;
' </Row>'+CRLF )
FOR i := 1 TO Len(aFooter)
FWrite( nFile,;
' <Row ss:StyleID="'+aStyleFooter[1]+'">'+CRLF+;
' <Cell><Data ss:Type="String">'+XmlEncode(ConvToAnsiCP(aFooter[i]))+'</Data></Cell>'+CRLF+;
' </Row>'+CRLF )
NEXT
FWrite( nFile,;
' </Table>'+CRLF+;
' </Worksheet>'+CRLF+;
'</Workbook>'+CRLF )
FClose( nFile )
IF lStart == NIL .OR. lStart
StartFile( cFile )
ENDIF
RETURN NIL
FUNC XmlEncode( cStr )
RETURN StrTran( StrTran( StrTran( Trim(cStr), "&", "&" ), "<", "<" ), ">", ">" )
PROC StartFile( cFile, cParam, cDir )
IF cParam == NIL; cParam := ""; ENDIF
IF cDir == NIL; cDir := ""; ENDIF
* IF M->terminalServices
* AlertaOk( "Em acesso remoto nÆo ‚ possivel abrir"+CR+cFile )
* RETURN
* ENDIF
DllCall( "SHELL32.DLL", DLL_STDCALL, "ShellExecuteA",;
AppDesktop():GetHWND(), "open", cFile, cParam, cDir, 1 )
RETURN
p.s. gibt es für oExcel:SaveAs() in der Office 2007 nicht eine XlFileFormat Konstante ?
excel' findet ...