Prezados(as) amigos(as), bom dia...
Estou tendo um problema para utilizar a exportação do FlexGrid para o Excell utilizando a função que se encontra na seção de diga e outras do genero. Data iniciadas em 0 (de 1 a 9) e campos string mais com conteudo exclusivamento numerico (CGC por exemplo) não são exportados de forma correta. Data inverte dia pelo mes e CGC trunca o conteudo, estouro de celula.
Alguem poderia sugerir uma solução para formatar corretamento a excell ??
Segue código:
Public Function CopyToExcel(InFlexGrid As Object, Nome As String) As Boolean
' Exportar dados de FlexGrid para Excel
If Not TypeOf InFlexGrid Is MSHFlexGrid Then Exit Function
Dim R, C, Buf, LstRow, LstCol
Dim FormatMoney As Boolean
Dim MyExcel As Excel.Application
Dim wbExcel As Excel.Workbook
Dim shExcel As Excel.Worksheet
On Error Resume Next
Set MyExcel = GetObject(, "Excel.Application")
If Err.Number <> 0 Then
Set MyExcel = CreateObject("Excel.Application")
End If
Set wbExcel = MyExcel.Workbooks.Add
Set shExcel = wbExcel.Worksheets.Add
shExcel.Name = Nome$
shExcel.Activate
LstCol = 0
For C = 0 To InFlexGrid.Cols - 1
InFlexGrid.Col = C
LstRow = 0
shExcel.Columns(Chr(Asc("A") + C)).ColumnWidth = InFlexGrid.ColWidth(C) / 72
For R = 0 To InFlexGrid.Rows - 1
InFlexGrid.Row = R
Err.Clear
Buf = InFlexGrid.TextMatrix(R, C)
If Buf <> "" Then
FormatMoney = False
If InStr(Buf, vbCrLf) Then
Buf = Replace(Buf, vbCrLf, vbLf)
Do While Right(Buf, 1) = vbLf
Buf = Left(Buf, Len(Buf) - 1)
Loop
shExcel.Range(Chr(Asc("A") + C)).WrapText = True
ElseIf Format(CDbl(Buf), csFormatMoneyZero) = Buf Then
If Err.Number = 0 Then
Buf = Str(CDbl(Buf))
FormatMoney = True
End If
End If
If Buf <> "" Then
If InFlexGrid.MergeRow(R) Then
For LstCol = C To 1 Step -1
If InFlexGrid.TextMatrix(R, LstCol - 1) <> InFlexGrid.TextMatrix(R, C) Then
Exit For
End If
Next
If LstCol <> C Then
shExcel.Range(Chr(Asc("A") + LstCol) & (R + 1), _
Chr(Asc("A") + C) & (R + 1)).MergeCells = True
shExcel.Range(Chr(Asc("A") + LstCol) & (R + 1), _
Chr(Asc("A") + C) & (R + 1)).BorderAround
End If
End If
If InFlexGrid.MergeCol(C) And LstRow <> R Then
If InFlexGrid.TextMatrix(LstRow, C) = InFlexGrid.TextMatrix(R, C) Then
shExcel.Range(Chr(Asc("A") + C) & (LstRow + 1), _
Chr(Asc("A") + C) & (R + 1)).MergeCells = True
shExcel.Range(Chr(Asc("A") + C) & (LstRow + 1), _
Chr(Asc("A") + C) & (R + 1)).BorderAround
Else
LstRow = R
End If
End If
shExcel.Range(Chr(Asc("A") + C) & _
(R + 1)).Font.Color = InFlexGrid.CellForeColor
If R < InFlexGrid.FixedRows Or C < InFlexGrid.FixedCols Then
shExcel.Range(Chr(Asc("A") + C) & _
(R + 1)).Font.Bold = True
' shExcel.Range(Chr(Asc("A")+c) & _
' (r+1)).Font.BackColor = 40
End If
shExcel.Range(Chr(Asc("A") + C) & (R + 1)).value = Buf
If FormatMoney Then
shExcel.Range(Chr(Asc("A") + C) & _
(R + 1)).NumberFormat = "#,##0.00;#,##0.00;#,##0.00"
End If
End If
End If
Next
Next
If TextoAdicional$ <> "" Then
' shExcel.Rows(Str(r+2)).Delete (xlShiftUp)
Do While Right(TextoAdicional$, 1) = vbLf
TextoAdicional$ = Left(TextoAdicional$, _
Len(TextoAdicional$) - 1)
Loop
shExcel.Range("A" & (R + 2)).value = TextoAdicional$
End If
MyExcel.Visible = True
Set shExcel = Nothing
Set wbExcel = Nothing
Set MyExcel = Nothing
CopyToExcel = True
End Function
