*-------------------------------------------------------------------------------------------------------------------------------------------------------- * (EN) AUTOGENERATED - ATTENTION!! - NOT INTENDED FOR EXECUTION!! USE ONLY FOR MERGING CHANGES AND STORING WITH SCM TOOLS!! *-------------------------------------------------------------------------------------------------------------------------------------------------------- *< FOXBIN2PRG: Version="1.21" SourceFile="excelxml.vcx" CPID="1252" /> (Solo para binarios VFP 9 / Only for VFP 9 binaries) * * DEFINE CLASS excelxml AS custom *< CLASSDATA: Baseclass="custom" Timestamp="" Scale="Pixels" Uniqueid="" /> * *m: about && About ExcelXML class *m: addnewstyle && Cria o estilo para o excel caso ainda não exista um igual e retorna o a string xml do estilo criado. *m: buildcolumnsstyles && Cria os estilos para uso das colunas e linhas. Ou seja, cada celula do grid é analizada para compor o seu estilo. *m: buildcolumnswidth && Cria propriedades com as definições de cada coluna *m: buildheadersstyles && Cria os estilos para uso do cabeçalho *m: buildrows && Prepara o conteudo da tabela baseado nos estilos encontrados. *m: colortostrhexa && Converto a cor do vfp para hexadecimal *m: getcolumn && Retorna o objeto da coluna conforme sua ordem de apresentação no grid *m: getcolumnalign && Retorna o alinhamento de um objeto para ser usado na linha/coluna (célula) do Excel *m: getcolumnheader && Retorna o nome do header da coluna indicada *m: getcurrentcontrolobject && Retorna o objeto corrente dentro da linha/coluna *m: hascolumnvisible && Retorna o numero de colunas visiveis no grid *m: progress && Method used to show the percentage processed. *m: save && Creates the Excel XML file. *m: seekstyle && Busco o estilo que será usado na Coluna/Linha (célula) *p: alias && Name of the table/cursor defined in the Grid or name of current table/cursor opened. *p: columncount && Returns the number of columns included in the Excel file. *p: crlf *p: dateformat && Specifies the date format. *p: file && Inform the name of Excel file. If you don't inform the name with the extension, the XML extension will be included. The default file name is "Book1" *p: gridobject && Inform the grid control object to convert a grid control in an Excel XML file. *p: hasfilter && .T. Includes the option Filter in all columns in the generated file. *p: lockheader && .T. locks the header in the generated file. This option in Excel is called by Freeze Top Row. *p: openaftersaving && .T. to open the file after saving it. *p: rowcount && Returns the number of rows included in the Excel file. *p: setstyles && Defines if the Excel file will have all the grid graphical attributes transported. *p: sheetname && Excel sheet name. The default name is "Sheet1" *p: stylecodenumber *p: version && Object that contain the information about this class. *p: xmlencoding && XML encoding type used to set the code that defines special characters. Default code is "iso-8859-1". *a: afields[1,18] && Array with information about the structure of the table in a specified work area, specified by a table alias, or in the currently selected work area in an array and returns the number of fields in the table. *p: _memberdata && XML Metadata for customizable properties * HIDDEN afields,crlf,dateformat,stylecodenumber PROTECTED alias * alias = columncount = 0 crlf = dateformat = file = gridobject = hasfilter = .F. Height = 16 lockheader = .F. Name = "excelxml" openaftersaving = .F. rowcount = 0 setstyles = .T. sheetname = Sheet1 stylecodenumber = 0 version = Width = 70 xmlencoding = iso-8859-1 _memberdata = * PROCEDURE about && About ExcelXML class messagebox("ExcelXML " + this.version.number + " " + this.version.datetime + this.CRLF +; "Converts a Grid control into a Microsoft Excel XML file" + this.CRLF +; "" + this.CRLF +; "Created by "+ this.version.author + this.CRLF +; this.version.CountryAndCity + this.CRLF +; this.version.url + this.CRLF +; this.version.email, 64, "About ExcelXML") ENDPROC PROTECTED PROCEDURE addnewstyle && Cria o estilo para o excel caso ainda não exista um igual e retorna o a string xml do estilo criado. lparameters plcType, plnRow, plnCol ,; plcAlignH, plcAlignV, plcFontName, plcFontFamily ,; plcFontSize, plcForeColor, plcFontBold, plcFontItalic ,; plcFontUnderline, plcFontStrikeThru, plcBackColor, plcPattern ,; plcFormat local lcStyleCode, lcXmlStyle lcXmlStyle = "" *- Definição de bordas entre as linhas/colunas (células) lcXmlBorderStyle = "" lcTop = "0" lcBottom = "0" if this.GridObject.GridLines >= 1 and this.Setstyles lcGridLineWidth = iif(plcType="c", alltrim(str(iif(this.GridObject.GridLineWidth>=4, 3, this.GridObject.GridLineWidth))), "1") lcGridLineColor = iif(plcType="c", this.ColorToStrHexa(this.GridObject.GridLineColor), this.ColorToStrHexa(rgb(100,100,100))) lcXmlBorderStyle = [ ] + this.CRLF *- Linhas na horizontal if inlist(this.GridObject.GridLines, 1, 3) lcXmlBorderStyle = lcXmlBorderStyle + [ ] + this.CRLF lcXmlBorderStyle = lcXmlBorderStyle + [ ] + this.CRLF endif *- Linhas na vertical if inlist(this.GridObject.GridLines, 2, 3) if this.GridObject.GridLines = 2 if plnRow = 1 &&- Se for a primeira linha lcTop = "1" lcXmlBorderStyle = lcXmlBorderStyle + [ ] + this.CRLF else if plnRow = (this.RowCount-1) &&- Se for a ultima linha lcBottom = "1" lcXmlBorderStyle = lcXmlBorderStyle + [ ] + this.CRLF endif endif endif lcXmlBorderStyle = lcXmlBorderStyle + [ ] + this.CRLF lcXmlBorderStyle = lcXmlBorderStyle + [ ] + this.CRLF endif lcXmlBorderStyle = lcXmlBorderStyle + [ ] + this.CRLF else lcXmlBorderStyle = [ ] + this.CRLF endif *- Adiciono no cursor caso não ache um registro com os mesmos dados if not seek(plcAlignH + plcAlignV + plcFontName + plcFontFamily + ; plcFontSize + plcForeColor + plcFontBold + plcFontItalic + ; plcFontUnderline + plcFontStrikeThru + plcBackColor + plcPattern +; plcFormat + lcTop + lcBottom ,; "xxxStylesProperties","idxStyle") this.StyleCodeNumber = this.StyleCodeNumber + 1 lcStyleCode = alltrim(lower(plcType))+transform(this.StyleCodeNumber, "@L 99999") *- xml de estilo da celula lcXmlStyle = [ ] insert into xxxStylesProperties ; values ( lcStyleCode ,; plcAlignH ,; plcAlignV ,; plcFontName ,; plcFontFamily ,; plcFontSize ,; plcForeColor ,; plcFontBold ,; plcFontItalic ,; plcFontUnderline ,; plcFontStrikeThru ,; plcBackColor ,; plcPattern ,; plcFormat ,; lcTop ,; lcBottom ,; lcXmlStyle ) endif insert into xxxStylesRowCol ; values ( transform(plnRow, "@L 999999") ,; transform(plnCol, "@L 999") ,; xxxStylesProperties.ssCode ) return lcXmlStyle ENDPROC PROTECTED PROCEDURE buildcolumnsstyles && Cria os estilos para uso das colunas e linhas. Ou seja, cada celula do grid é analizada para compor o seu estilo. *!* 12.10.2016 *!* marius.mutu *!* try catch endtry for dynamic properties (ex: this.readonly - error) local lcAlignH, lcAlignV, lcFontName, lcFontFamily, ; lcFontSize, lcForeColor, lcFontBold, lcFontItalic, ; lcFontUnderline, lcFontStrikeThru, lcBackColor, lcPattern, ; lcFormat, lcXmlBorderStyle, lcXmlStyles, lnRow, lnCol, lnRowFound this.StyleCodeNumber = 0 lnRow = 0 lnCol = 0 lcXmlStyles = "" *- Verifico os estilos de todas as linhas/colunas do grid select (this.Alias) go top scan lnRow = lnRow + 1 if not this.SetStyles and lnRow >= 2 &&- Não aplica os estilos ao grid. exit endif for lnCol = 1 to this.GridObject.ColumnCount loColumn = this.GetColumn(lnCol) if not loColumn.Visible &&-Considero somente as colunas visiveis loop endif *- Formato dos dados da linha/coluna (célula) lcDataColumn = evaluate(loColumn.ControlSource) loCurrentControl = this.GetCurrentControlObject(loColumn) lcFormat = "" if not isnull(loCurrentControl) do case case inlist(vartype(lcDataColumn),"N","Y") if lower(loCurrentControl.BaseClass) $ "textbox//spinner" if not empty(loColumn.InputMask) lcInputMask = loColumn.InputMask if occurs(".",lcInputMask) > 0 lcFormat = "#,##0." + replicate("0", len(subs(lcInputMask, rat(".",lcInputMask)+1))) else lcFormat = "#,##0" endif else lnRowFound = ascan(this.AFields, iif("."$loColumn.ControlSource, substr(loColumn.ControlSource, at(".",loColumn.ControlSource)+1), loColumn.ControlSource), -1,-1, 1, 15) if lnRowFound > 0 and this.AFields[lnRowFound,4] > 0 lcFormat = "#,##0." + replicate("0", this.AFields[lnRowFound,4]) else lcFormat = "" endif endif endif if lower(loCurrentControl.BaseClass) $ "checkbox//optiongroup" lcFormat = "" endif case vartype(lcDataColumn) = "D" lcFormat = this.DateFormat + ";@" case vartype(lcDataColumn) = "T" if lower(loCurrentControl.BaseClass) = "textbox" lnHasSeconds = loCurrentControl.Seconds else lnHasSeconds = 2 endif if lnHasSeconds = 0 *- Data e hora sem segundos lcFormat = this.DateFormat+"\ h:mm" + iif(set("hours")=12," AM/PM","") else *- Data e hora com segundos lcFormat = this.DateFormat+"\ h:mm:ss" + iif(set("hours")=12," AM/PM","") endif case vartype(lcDataColumn) = "L" lcFormat = "True/False" otherwise lcFormat = "" endcase endif lcFormat = padr(lcFormat, len(xxxStylesProperties.ssFormat)) *- Requisitos fixos para o estilo lcFontFamily = padr("Swiss", len(xxxStylesProperties.ssFontFamily)) lcPattern = padr("Solid", len(xxxStylesProperties.ssPattern)) *- Alinhamento Horizontal do texto da coluna/linha if not isnull(loCurrentControl) and lower(loCurrentControl.BaseClass) = "combobox" lcAlignH = this.GetColumnAlign("H", loCurrentControl.Alignment, vartype(lcDataColumn)) lcAlignV = this.GetColumnAlign("V", loCurrentControl.Alignment, vartype(lcDataColumn)) else lcAlignH = this.GetColumnAlign("H", loColumn.Alignment, vartype(lcDataColumn)) lcAlignV = this.GetColumnAlign("V", loColumn.Alignment, vartype(lcDataColumn)) endif *- cor de fundo da coluna/linha if not empty(loColumn.DynamicBackColor) TRY lcBackColor = this.ColorToStrHexa( evaluate(loColumn.DynamicBackColor) ) CATCH lcBackColor = this.ColorToStrHexa( loColumn.BackColor ) ENDTRY else lcBackColor = this.ColorToStrHexa( loColumn.BackColor ) endif *- cor da fonte da coluna/linha if not empty(loColumn.DynamicForeColor) TRY lcForeColor = this.ColorToStrHexa( evaluate(loColumn.DynamicForeColor) ) CATCH lcForeColor = this.ColorToStrHexa( loColumn.ForeColor ) ENDTRY else lcForeColor = this.ColorToStrHexa( loColumn.ForeColor ) endif *- fonte usada na coluna/linha if not empty(loColumn.DynamicFontName) TRY lcFontName = evaluate(loColumn.DynamicFontName) CATCH lcFontName = loColumn.FontName ENDTRY else lcFontName = loColumn.FontName endif lcFontName = padr(lcFontName, len(xxxStylesProperties.ssFontName)) *- tamanho da fonte da coluna/linha if not empty(loColumn.DynamicFontSize) TRY lcFontSize = transform(evaluate(loColumn.DynamicFontSize), "@L 999") CATCH lcFontSize = transform(loColumn.FontSize, "@L 999") ENDTRY else lcFontSize = transform(loColumn.FontSize, "@L 999") endif *- Fonte Italica da coluna/linha if not empty(loColumn.DynamicFontItalic) TRY lcFontItalic = iif(evaluate(loColumn.DynamicFontItalic), "1", "0") CATCH lcFontItalic = iif(loColumn.FontItalic, "1", "0") ENDTRY else lcFontItalic = iif(loColumn.FontItalic, "1", "0") endif *- Fonte Negrito da coluna/linha if not empty(loColumn.DynamicFontBold) TRY lcFontBold = iif(evaluate(loColumn.DynamicFontBold), "1", "0") CATCH lcFontBold = iif(loColumn.FontBold, "1", "0") ENDTRY else lcFontBold = iif(loColumn.FontBold, "1", "0") endif *- Fonte Underline da coluna/linha if not empty(loColumn.DynamicFontUnderline) TRY lcFontUnderline = iif(evaluate(loColumn.DynamicFontUnderline), "Single", "") CATCH lcFontUnderline = iif(loColumn.FontUnderline, "Single", "") ENDTRY else lcFontUnderline = iif(loColumn.FontUnderline, "Single", "") endif lcFontUnderline = padr(lcFontUnderline, len(xxxStylesProperties.ssFontUnderline)) *- Fonte Underline da coluna/linha if not empty(loColumn.DynamicFontStrikeThru) TRY lcFontStrikeThru = iif(evaluate(loColumn.DynamicFontStrikeThru), "1", "0") CATCH lcFontStrikeThru = iif(loColumn.FontStrikeThru, "1", "0") ENDTRY else lcFontStrikeThru = iif(loColumn.FontStrikeThru, "1", "0") endif lcFontStrikeThru = padr(lcFontStrikeThru, len(xxxStylesProperties.ssFontStrikeThru)) *- se o estilo já existir "lcXmlStyle" retorna "" lcXmlStyle = this.AddNewStyle( "c", lnRow, lnCol, ; lcAlignH, lcAlignV, lcFontName, lcFontFamily, ; lcFontSize, lcForeColor, lcFontBold, lcFontItalic, ; lcFontUnderline, lcFontStrikeThru, lcBackColor, lcPattern, ; lcFormat ) if not empty(lcXmlStyle) lcXmlStyles = lcXmlStyles + this.CRLF + lcXmlStyle endif endfor endscan return lcXmlStyles ENDPROC PROTECTED PROCEDURE buildcolumnswidth && Cria propriedades com as definições de cada coluna local lcXmlColumnsWidth, lnCol, lnColumnWidth lcXmlColumnsWidth = this.CRLF for lnCol = 1 to this.GridObject.ColumnCount loColumn = this.GetColumn(lnCol) if loColumn.Visible = .T. lnColumnWidth = iif(loColumn.width>700,700,loColumn.width) &&- Avoiding error in Excel lcXmlColumnsWidth = lcXmlColumnsWidth + [ ] + this.CRLF endif endfor return lcXmlColumnsWidth ENDPROC PROTECTED PROCEDURE buildheadersstyles && Cria os estilos para uso do cabeçalho local loColumn, loColumnHeader, lnCol, lcXmlStyles, lcXmlStyle, ; lcBackColor, lcForeColor, lcFontName, lcFontSize, lcFontItalic, ; lcFontBold, lcFontUnderline, lcFontStrikeThru, lcFormat, ; lcFontFamily, lcPattern, lcAlignH, lcAlignV, lcCollate lcXmlStyle = "" lcXmlStyles = "" this.StyleCodeNumber = 0 lcCollate = set("Collate") set collate to "MACHINE" *- Crio cursor para armazenar todos os estilos encontrados create cursor xxxStylesProperties ( ssCode c(6) ,; ssAlignH c(6) ,; ssAlignV c(6) ,; ssFontName c(40) ,; ssFontFamily c(5) ,; ssFontSize c(3) ,; ssFontColor c(7) ,; ssFontBold c(1) ,; ssFontItalic c(1) ,; ssFontUnderline c(6) ,; ssFontStrikeThru c(1) ,; ssBackColor c(7) ,; ssPattern c(5),; ssFormat c(40) ,; ssTop c(1) ,; ssBottom c(1) ,; ssStyle m ) select xxxStylesProperties index on ssAlignH + ssAlignV + ssFontName + ; ssFontFamily + ssFontSize + ssFontColor + ; ssFontBold + ssFontItalic + ssFontUnderline + ssFontStrikeThru + ; ssBackColor + ssPattern + ssFormat + ssTop + ssBottom tag idxStyle index on ssCode tag idxCode *- Crio cursor para gravar o estilo que sera usado pela linha/coluna (célula) create cursor xxxStylesRowCol ( ssRow c(6) ,; ssCol c(3) ,; ssCode c(6) ) select xxxStylesRowCol index on ssRow + ssCol tag idxRowCol set collate to lcCollate *- Verifico os estilos dos headers de cada coluna if this.GridObject.HeaderHeight > 0 for lnCol = 1 to this.GridObject.ColumnCount loColumn = this.GetColumn(lnCol) loColumnHeader = this.GetColumnHeader(loColumn) lcBackColor = this.ColorToStrHexa( iif(this.SetStyles, loColumnHeader.BackColor, rgb(255,255,255)) ) lcForeColor = this.ColorToStrHexa( iif(this.SetStyles, loColumnHeader.ForeColor, rgb(0,0,0)) ) lcFontName = padr(loColumnHeader.FontName, len(xxxStylesProperties.ssFontName)) lcFontSize = transform(loColumnHeader.FontSize, "@L 999") lcFontItalic = iif(loColumnHeader.FontItalic, "1", "0") lcFontBold = iif(loColumnHeader.FontBold or this.SetStyles=.f., "1", "0") lcFontUnderline = padr(iif(loColumnHeader.FontUnderline or this.SetStyles=.f., "Single", ""), len(xxxStylesProperties.ssFontUnderline)) lcFontStrikeThru = iif(loColumnHeader.FontStrikeThru, "1", "0") lcFormat = padr("", len(xxxStylesProperties.ssFormat)) lcFontFamily = padr("Swiss", len(xxxStylesProperties.ssFontFamily)) lcPattern = padr("Solid", len(xxxStylesProperties.ssPattern)) lcAlignH = iif(this.SetStyles, this.GetColumnAlign("H", loColumnHeader.Alignment), "Left") lcAlignV = iif(this.SetStyles, this.GetColumnAlign("V", loColumnHeader.Alignment), "Center") *- se o estilo já existir "lcXmlStyle" retorna "" lcXmlStyle = this.AddNewStyle( "h", 0, lnCol, ; lcAlignH, lcAlignV, lcFontName, lcFontFamily, ; lcFontSize, lcForeColor, lcFontBold, lcFontItalic, ; lcFontUnderline, lcFontStrikeThru, lcBackColor, lcPattern, ; lcFormat ) if not empty(lcXmlStyle) lcXmlStyles = lcXmlStyles + this.CRLF + lcXmlStyle endif endfor endif return lcXmlStyles ENDPROC PROTECTED PROCEDURE buildrows && Prepara o conteudo da tabela baseado nos estilos encontrados. local lcXmlRows, lcDataType, lcDataColumn, lcAuxDataColumn, lnRow, lnCol, loColumn, loColumnHeader, loCurrentControl, ; lnPercent, lnCountRowSource, lcCountOption, laArrayTmp, lcComboOption, lcToolTipText, lnBytes, llHasDecimals, ; lnSetDecimals, lnRowFound, lnYear lcXmlRows = this.CRLF lnRow = 0 lnCol = 0 lnBytes = 0 lnSetDecimals = set("Decimals") *- Adiciono a linha do Header no arquivo excel if this.GridObject.HeaderHeight > 0 lcXmlRows = lcXmlRows + [ ] + this.CRLF for lnCol = 1 to this.GridObject.ColumnCount loColumn = this.GetColumn(lnCol) loColumnHeader = this.GetColumnHeader(loColumn) if loColumn.Visible = .T. *- caso tenha tooltiptext lcToolTipText = "" if not empty(loColumnHeader.ToolTipText) lcToolTipText = []+; []+; []+alltrim(loColumnHeader.ToolTipText)+[]+; []+; [] endif *- linha do header lcXmlRows = lcXmlRows + [ ]+loColumnHeader.caption+[]+lcToolTipText+[] + this.CRLF endif endfor lcXmlRows = lcXmlRows + [ ] + this.CRLF endif lcXmlRows = lcXmlRows + this.CRLF *- Adiciono a linha do Registro no arquivo excel select (this.Alias) go top scan lnRow = lnRow + 1 lcXmlRows = lcXmlRows + [ ] + this.CRLF *- percentual processado lnPercent = int((lnRow / (this.RowCount - (iif(this.GridObject.HeaderHeight > 0, 1, 0))) ) * 100) this.Progress(lnPercent) *- faço a varredura em todas as colunas for lnCol = 1 to this.GridObject.ColumnCount loColumn = this.GetColumn(lnCol) if not loColumn.Visible loop endif *- Verifico o tipo de dado da coluna lcDataColumn = evaluate(loColumn.ControlSource) loCurrentControl = this.GetCurrentControlObject(loColumn) *- se não tem objeto de controle na linha da coluna não levo a informação da tabela ao excel if isnull(loCurrentControl) lcDataType = "String" lcDataColumn = "" else do case case vartype(lcDataColumn) $ "N//Y" lcDataType = "Number" *- Se o currentcontrol da coluna for um combobox mostro o seu conteudo ao inves da posição numerica if lower(loCurrentControl.BaseClass) = "combobox" try do case *- Mostro o texto do value case loCurrentControl.RowSourceType = 1 lcDataType = "String" if not empty(loCurrentControl.RowSource) lcAuxDataColumn = alltrim(loCurrentControl.RowSource) lcAuxDataColumn = strtran(strtran(strtran(lcAuxDataColumn," ,",","), ", ",","), " , ", ",") lcCountOption = occurs(",",lcAuxDataColumn)+1 dimension laArrayTmp[lcCountOption] for lnCountRowSource = 1 to lcCountOption lcComboOption = substr(lcAuxDataColumn, 1, iif(lnCountRowSource < lcCountOption, at(",",lcAuxDataColumn)-1, len(lcAuxDataColumn)) ) lcAuxDataColumn = strtran(lcAuxDataColumn, lcComboOption + iif(lcCountOption>=2,",",""), "") laArrayTmp[lnCountRowSource] = lcComboOption endfor lcDataColumn = evaluate("laArrayTmp["+alltrim(str(lcDataColumn))+"]") endif *- Mostro o texto do array do combo case loCurrentControl.RowSourceType = 5 lcDataType = "String" *- Se for um array objeto ex: thisform.ArrayName ou MyObj.ArrayName if occurs(".", loCurrentControl.RowSource) > 0 lcObjArrayName = substr(loCurrentControl.RowSource, 1, rat(".",loCurrentControl.RowSource)-1) *- Se for um array objeto publico if type(lcObjArrayName) = "O" lcAuxDataColumn = loCurrentControl.RowSource+"["+alltrim(str(lcDataColumn))+"]" else lcArrayName = substr(loCurrentControl.RowSource, rat(".",loCurrentControl.RowSource)+1) lnCountObjectHierarchy = occurs(".", sys(1272, this.GridObject)) lcAuxDataColumn = "this.GridObject"+replicate(".Parent",lnCountObjectHierarchy)+"."+lcArrayName+"["+alltrim(str(lcDataColumn))+"]" endif *- Array comum else lcAuxDataColumn = loCurrentControl.RowSource+"["+alltrim(str(lcDataColumn))+"]" endif lcDataColumn = evaluate(lcAuxDataColumn) *- Qualquer outro mostro o conteudo do campo e não o conteudo do array otherwise lcDataColumn = lcDataColumn endcase catch to loError endtry if vartype(loError) = "O" messagebox( "Combo array '"+loCurrentControl.RowSource+"' in column '"+loColumn.name+"' not is valid", 48) select (this.Alias) go top return .f. endif else lnRowFound = ascan(this.AFields, iif("."$loColumn.ControlSource, substr(loColumn.ControlSource, at(".",loColumn.ControlSource)+1), loColumn.ControlSource), -1,-1, 1, 15) if lnRowFound > 0 and this.AFields[lnRowFound,4] > 0 llHasDecimals = .t. set decimals to this.AFields[lnRowFound,4] else llHasDecimals = .f. endif endif case vartype(lcDataColumn) = "D" lcDataType = "DateTime" if not empty(nvl(lcDataColumn,"")) lnYear = iif(year(lcDataColumn)<1900,1900,year(lcDataColumn)) lcAuxDataColumn = str(lnYear,4)+"-"+transform(month(lcDataColumn),"@L 99")+"-"+transform(day(lcDataColumn),"@L 99")+"T00:00:00.000" lcDataColumn = lcAuxDataColumn else lcDataType = "String" lcDataColumn = "" endif case vartype(lcDataColumn) = "T" lcDataType = "DateTime" if not empty(nvl(lcDataColumn,"")) lnYear = iif(year(lcDataColumn)<1900,1900,year(lcDataColumn)) lcAuxDataColumn = str(lnYear,4)+"-"+transform(month(lcDataColumn),"@L 99")+"-"+transform(day(lcDataColumn),"@L 99")+; "T"+transform(hour(lcDataColumn),"@L 99")+":"+transform(minute(lcDataColumn),"@L 99")+":"+transform(sec(lcDataColumn),"@L 99")+".000" lcDataColumn = lcAuxDataColumn else lcDataType = "String" lcDataColumn = "" endif case vartype(lcDataColumn) = "L" lcDataType = "Number" lcDataColumn = iif(lcDataColumn, 1, 0) otherwise lcDataType = "String" if isnull(lcDataColumn) lcDataColumn = "" endif endcase endif *- removing invalid characters if lcDataType = "String" and ("<" $ lcDataColumn or ">" $ lcDataColumn) lcDataColumn = strtran(strtran(lcDataColumn, "<", "["), ">", "]") endif *- incluo a linha de dados lcXmlRows = lcXmlRows + [ ]+alltrim(transform(lcDataColumn, ""))+[] + this.CRLF *- devolvo o atributo original if llHasDecimals set decimals to lnSetDecimals endif endfor lcXmlRows = lcXmlRows + [ ] + this.CRLF lnBytes = lnBytes + strtofile( lcXmlRows + this.CRLF, this.File, 1) lcXmlRows = "" endscan return lnBytes ENDPROC PROTECTED PROCEDURE colortostrhexa && Converto a cor do vfp para hexadecimal lparameters plnColor local lnDecimalColor lnDecimalColor = substr(transform(plnColor, '@0'),5) return "#"+right(lnDecimalColor,2) + substr(lnDecimalColor,3,2) + left(lnDecimalColor,2) ENDPROC PROTECTED PROCEDURE getcolumn && Retorna o objeto da coluna conforme sua ordem de apresentação no grid lparameters plcColumnNumber local lnCol for lnCol = 1 to this.GridObject.ColumnCount if this.GridObject.Columns(lnCol).ColumnOrder = plcColumnNumber return this.GridObject.Columns(lnCol) endif endfor ENDPROC PROTECTED PROCEDURE getcolumnalign && Retorna o alinhamento de um objeto para ser usado na linha/coluna (célula) do Excel lparameters plcWhat, plnAlignment, plcVartype local lcAlignment, lcAlignH, lcAlignV plcVartype = evl(plcVartype,"") lcAlignment = alltrim(str(plnAlignment)) *- Alinhamento Horizontal do texto da coluna/linha if plcWhat = "H" do case case lcAlignment $ "0//4//7" lcAlignH = "Left" case lcAlignment $ "1//5//8" lcAlignH = "Right" case lcAlignment $ "2//6//9" lcAlignH = "Center" otherwise lcAlignH = iif(plcVartype $ "N//Y", "Right", "Left") endcase lcAlignH = padr(lcAlignH, len(xxxStylesProperties.ssAlignH)) return lcAlignH endif *- Alinhamento vertical do texto da coluna/linha if plcWhat = "V" do case case lcAlignment $ "4//5//6" lcAlignV = "Top" case lcAlignment $ "7//8//9" lcAlignV = "Bottom" case lcAlignment $ "0//1//2" lcAlignV = "Center" otherwise lcAlignV = "Center" endcase lcAlignV = padr(lcAlignV, len(xxxStylesProperties.ssAlignV)) return lcAlignV endif ENDPROC PROTECTED PROCEDURE getcolumnheader && Retorna o nome do header da coluna indicada lparameters ploColumn local loReturn, lnx loReturn = "" if ploColumn.ControlCount > 0 for lnx = 1 to ploColumn.ControlCount if lower(ploColumn.Controls(lnx).BaseClass) = "header" loReturn = ploColumn.Controls(lnx) exit endif endfor endif return loReturn ENDPROC PROTECTED PROCEDURE getcurrentcontrolobject && Retorna o objeto corrente dentro da linha/coluna lparameters ploGridColumn local lcCurrentControl if not empty(ploGridColumn.DynamicCurrentControl) lcCurrentControl = evaluate(ploGridColumn.DynamicCurrentControl) else lcCurrentControl = ploGridColumn.CurrentControl endif if not empty(lcCurrentControl) return evaluate("ploGridColumn."+lcCurrentControl) else return null endif ENDPROC PROTECTED PROCEDURE hascolumnvisible && Retorna o numero de colunas visiveis no grid local lnCol, llReturn llReturn = .f. for lnCol = 1 to this.GridObject.ColumnCount if this.GridObject.Columns(lnCol).Visible llReturn = .t. exit endif endfor return llReturn ENDPROC PROCEDURE Init */---------------------------------------------------------------------------------------------------/* */ Descripton..: - Classe para converter o grid do vfp em um arquivo xml para o Excel. /* */ - A grande vantagem na utilização é que NÃO NECESSITA DO EXCEL INSTALADO /* */ pois em nenhum momento o Excel é instanciado para automação. /* */ Apesar de ser um arquivo xml, se encontra no padrão Microsoft onde é reconhecido /* */ pelo Excel como "Planilha XML 2003 (*.xml)". Dessa forma fica restrito o uso /* */ para Excel 2003 ou superior. /* */ /* */ - Se o Excel estiver instalado o icone do arquivo gerado será reconhecido /* */ pelo Excel e abrindo o arquivo será reconhecido como se fosse um XLS ou XLSX, /* */ ou seja, tudo será transparente para o Excel. /* */ /* */ - Praticamente todos os recursos visuais do grid, headers, colunas e linhas /* */ são tratados na exportação. Segue abaixo as propriedades reconhecidas: /* */ /* */ Header Properties /* */ --------------------------------- /* */ ToolTipText / HeaderHeight / Alignment / FontBold / FontItalic / FontUnderline / /* */ FontStrikeThru / FontName / FontSize / ForeColor / BackColor / Caption / /* */ /* */ Columns Properties /* */ --------------------------------- /* */ ControlSource / BaseClass / InputMask / Seconds / RowHeight / Alignment / /* */ FontBold / FontItalic / FontUnderline / FontStrikeThru / FontName / FontSize / /* */ ForeColor / FontBackColor / CurrentControl / DynamicFontBold / DynamicFontItalic /* */ DynamicFontUnderline / DynamicFontStrikeThru / DynamicCurrentControl / /* */ DynamicFontName / DynamicFontSize / DynamicForeColor / DynamicBackColor / /* */ ColumnCount / ColumnOrder / Width / Visible / Combobox.Alignment / /* */ Combobox.RowSource / Combobox.RowSourceType /* */ /* */ Environment /* */ --------------------------------- /* */ set date / set century / set hours /* */ /* */ */ Goals */ ------ */ a) Possibilidade de gerar planilhas com mais de 65,535 linhas superando */ a limitaçao nativa do VFP */ b) Converte um grid em planilha Excel assumindo 99% do visual do grid */ c) Easy to implement and it is not necessary to change your code */ d) Compativel com Excel 2003 ou superior */ e) Pode ser aberto pelo OpenOffice reduzindo erros de conversão */ f) Ao abrir o arquivo pelo Excel é possivel salvar em outros formatos */ g) Nao precisa ter o Excel instalado */ */ /* */ Author......: Rodrigo Bruscain /* */ Date........: 25/05/2013 /* */ Country.....: Brazil - São Paulo - SP /* */ Version.....: 1.08 /* */---------------------------------------------------------------------------------------------------/* this.CRLF = chr(13) + chr(10) local lcDateFormat, lcCentury lcDateFormat = set("Date") lcCentury = iif(set("century")="ON","yyyy","yy") do case case inlist(lcDateFormat, "AMERICAN", "MDY") && month/day/year this.DateFormat = "mm/dd/"+lcCentury case lcDateFormat = "ANSI" && year.month.day this.DateFormat = lcCentury+".mm.dd" case inlist(lcDateFormat, "BRITISH", "DMY", "FRENCH") && day/month/year this.DateFormat = "dd/mm/"+lcCentury case lcDateFormat = "GERMAN" && day.month.year this.DateFormat = "dd.mm."+lcCentury case lcDateFormat = "ITALIAN" && day-month-year this.DateFormat = "dd-mm-"+lcCentury case inlist(lcDateFormat, "JAPAN", "YMD") && year/month/day this.DateFormat = lcCentury+"/mm/dd" case lcDateFormat = "USA" && month-day-year this.DateFormat = "mm-dd-"+lcCentury otherwise this.DateFormat = "dd/mm/"+lcCentury endcase *- version object this.version = createobject("empty") addproperty(this.version, "Number", "Beta 1.08") addproperty(this.version, "DateTime", "Feb.21.2014 3:59:41 AM") addproperty(this.version, "Author", "Rodrigo Duarte Bruscain") addproperty(this.version, "CountryAndCity", "kitchener ON - Canada") addproperty(this.version, "Url", "http://vfpx.codeplex.com/wikipage?title=ExcelXML") addproperty(this.version, "Email", "bruscain@hotmail.com") ENDPROC PROCEDURE progress && Method used to show the percentage processed. lparameters plnPercent ENDPROC PROCEDURE save && Creates the Excel XML file. lparameters plcFile local lcCreatedDate, lnCol, lcSetPoint, loForm, lcAlias, lnRecno, ; lcXmlStart, lcXmlDocumentProperties, lcXmlExcelWorkbook, lcStringStyles, ; lcXmlAllStyles, lcXmlFreezePanes, lcStringFilter, lcStringColumnWidth, ; lcXmlWorksheet_part1, lcXmlWorksheet_part2, lnBytes, loError plcFile = iif(empty(plcFile),"Book1",plcFile) this.File = iif(empty(this.File),plcFile,this.File) this.File = this.File + iif(empty(justext(this.File)),".XML","") if empty(alias()) messagebox("No table is open in the current work area. ", 48) return .f. endif *- crio um grid virtual caso a nao exista um grid para conversao, *- ou seja, estou convertendo somente a tabela if vartype(this.GridObject) <> "O" loForm = createobject("form") loForm.AddObject("grid1","grid") loForm.Grid1.RecordSource = alias() loForm.Grid1.visible = .t. loForm.refresh() this.GridObject = loForm.Grid1 this.SetStyles = .f. endif *- environment if this.GridObject.RecordSourceType = 1 this.Alias = this.GridObject.RecordSource else this.Alias = alias() endif lnRecno = recno() afields(this.afields,this.Alias) *- Data da criação do arquivo excel lcCreatedDate = str(year(date()),4)+"-"+transform(month(date()),"@L 99")+"-"+transform(day(date()),"@L 99")+"T"+time()+"Z" *- Numero de colunas válidas para o excel this.ColumnCount = 0 for lnCol = 1 to this.GridObject.ColumnCount if this.GridObject.Columns(lnCol).Visible = .T. this.ColumnCount = this.ColumnCount + 1 endif endfor *- Numero de linhas disponíveis para o excel this.RowCount = 0 select (this.Alias) count to this.RowCount go top if this.GridObject.HeaderHeight > 0 this.RowCount = this.RowCount + 1 endif *- verifico se tudo esta ok para prosseguir if isnull(this.GridObject) or this.GridObject.ColumnCount <= 0 and this.HasColumnVisible() return .f. endif *- No Excel casas decimais obrigatóriamente trabalham com ponto "." lcSetPoint = set("Point") set point to "." *- Inicio tratamento dos dados text to lcXmlStart textmerge pretext 2 noshow >"?> endtext text to lcXmlDocumentProperties textmerge pretext 2 noshow <> <> <> <> 12.00 endtext text to lcXmlExcelWorkbook textmerge pretext 2 noshow 8130 15135 120 45 False False endtext *- Crio os estilos de cores/fontes/formato/etc das colunas *- Depois junto com o estilo padrão todos os estilos encontrados *- Estilos são todas as formatões da células combinadas onde um estilo pode ser usado *- por várias céluas ou por uma única célula. lcStringStyles = "" lcStringStyles = this.BuildHeadersStyles() &&- Estilos do header lcStringStyles = lcStringStyles + this.BuildColumnsStyles() &&- Estilos das linhas/colunas text to lcXmlAllStyles textmerge pretext 2 noshow <> endtext *- Congelando paineis na horizontal e vertical do case *- Congelo a linha do header case this.GridObject.LockColumns = 0 and (this.GridObject.HeaderHeight > 0 and this.LockHeader) text to lcXmlFreezePanes textmerge pretext 2 noshow 1 1 2 3 2 endtext *- congelo a linha do header e a coluna definida case this.GridObject.LockColumns > 0 and (this.GridObject.HeaderHeight > 0 and this.LockHeader) text to lcXmlFreezePanes textmerge pretext 2 noshow 1 1 <> <> 0 3 1 2 0 endtext *- congelo somente a coluna definida case this.GridObject.LockColumns > 0 and (this.GridObject.HeaderHeight = 0 or not this.LockHeader) text to lcXmlFreezePanes textmerge pretext 2 noshow 2 2 1 3 1 endtext otherwise lcXmlFreezePanes = "" endcase *- filtros na colunas lcStringFilter = "" if this.HasFilter and this.GridObject.HeaderHeight > 0 text to lcStringFilter textmerge pretext 2 noshow endtext endif *- tratamento do nome da planilha this.SheetName = chrtran(alltrim(substr(this.SheetName,1,31)), ':?][*/\','') this.SheetName = iif(empty(this.SheetName),"Sheet1", this.SheetName) *- Monto a tabela lcStringColumnWidth = this.BuildColumnsWidth() text to lcXmlWorksheet_part1 textmerge pretext 2 noshow <> endtext text to lcXmlWorksheet_part2 textmerge pretext 2 noshow