USUÁRIO:      SENHA:        SALVAR LOGIN ?    Adicione o VBWEB na sua lista de favoritos   Fale conosco 

 

  Fórum

  Visual Basic
Voltar
Autor Assunto:  Exportar dados de FlexGrid para Excel
Ralph Teixeira
RIO DE JANEIRO
RJ - BRASIL
ENUNCIADA !
Postada em 01/06/2006 10:05 hs            
Bom dia a todos
Gostaria de saber como usar esta função
desde ja agradeço a todos
'----------------------------------------------------------------------------
Sub CopyToExcel(InFlexGrid As MSFlexGrid, Nome$, _
               ByVal TextoAdicional$)
  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$ = StrTran(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
End Sub

Ralph Teixeira

   
Ex-FatBoy
Pontos: 2843 Pontos: 2843
LONDRINA
PR - BRASIL
ENUNCIADA !
Postada em 01/06/2006 13:30 hs            
   
Página(s): 1/1    

CyberWEB Network Ltda.    © Copyright 2000-2024   -   Todos os direitos reservados.
Powered by HostingZone - A melhor hospedagem para seu site
Topo da página