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,; ''+CRLF+; ''+CRLF+; ''+CRLF ) FWrite( nFile,; ' '+CRLF+; ' '+CRLF+; ' '+CRLF+; ' '+CRLF+; ' '+CRLF+; ' '+CRLF+; ' '+CRLF+; ' '+CRLF ) FWrite( nFile,; ' '+CRLF+; ' '+CRLF ) IF ValType( aColWidth ) == "A" FOR i := 1 TO Len( aColWidth ) cType := ValType( FieldGet( aFieldPos[i] ) ) FWrite( nFile,; ' '+CRLF ) NEXT ENDIF IF ValType( aHeader ) == "A" FOR i := 1 TO Len(aHeader) IF ValType( aHeader[i] ) == "C" FWrite( nFile,; ' '+CRLF+; ' '+XmlEncode(ConvToAnsiCP(aHeader[i]))+''+CRLF+; ' '+CRLF ) ELSE aFieldHeader := aHeader[i] ENDIF NEXT FWrite( nFile,; // Blank line ' '+CRLF+; ' '+CRLF ) ENDIF FWrite( nFile, ' '+CRLF ) IF aFieldHeader == NIL aFieldHeader := aFieldNames ENDIF FOR i := 1 TO nCount FWrite( nFile, ' '+ConvToAnsiCP(aFieldHeader[i])+''+CRLF ) NEXT nRecords := 0 FWrite( nFile, ' '+CRLF ) WHILE !EOF() .AND. nRecords <= nNext .AND. ( bWhile == NIL .OR. EVal( bWhile ) ) IF bFor == NIL .OR. EVal( bFor ) FWrite( nFile, ' '+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, ' '+cValue+''+CRLF ) NEXT ++nRecords FWrite( nFile, ' '+CRLF ) ENDIF DbSkip() ENDDO IF ValType( aTotal ) == "A" FWrite( nFile,; ' '+CRLF+; ' '+CRLF+; ' '+CRLF ) ++nRecords FWrite( nFile, ' '+CRLF ) FOR i := 1 TO Len( aTotal ) FWrite( nFile, ' '+CRLF ) NEXT FWrite( nFile, ' '+CRLF ) ENDIF FWrite( nFile,; // Blank line ' '+CRLF+; ' '+CRLF ) FOR i := 1 TO Len(aFooter) FWrite( nFile,; ' '+CRLF+; ' '+XmlEncode(ConvToAnsiCP(aFooter[i]))+''+CRLF+; ' '+CRLF ) NEXT FWrite( nFile,; '
'+CRLF+; ' '+CRLF+; ''+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