Export a Listview Object to Excel

Category:

Office/VBA

Type:

Snippets

Difficulty:

Intermediate

Author: Anonymous

Version Compatibility: Visual Basic 6, Visual Basic 5

More information:

This snippet of code lets you automatically export a Listview object to a Excel spreadsheet.

Instructions: Copy the declarations and code below and paste directly into your VB project.

Declarations:
' (None)

Code:

Sub ExportarListViewAExcel(ParamList As ListView, Optional ByVal szBookTitle
As String, Optional ByVal szSheetTitle As String)
'On Error GoTo ExportHandlerError
Dim Columna As Integer
Dim AppExcel As New Excel.Application
Dim Libro As Excel.Workbook
Dim Hoja As Excel.Worksheet
Dim CeldaActual As Integer  ' Celda actual en la Hoja
Dim ItemActual As Integer   ' Fila Actual en la Lista
Dim valor As String       'valor de la celda para saber si es un número
Dim Fecha As String    ' año para formatear
Dim aux1 As String          ' comparar si es OP
Dim aux2 As String          ' comparar si es OP
Dim texto As Boolean        'para comprobar cuando es texto

' Si la lista está vacia no se puede exportar.
If ParamList.ListItems.Count = 0 Then
    MsgBox "La lista seleccionada está vacia. No se puede exportar.",
vbInformation, App.Title
    Exit Sub
End If

Screen.MousePointer = vbHourglass

ParamList.Parent.Enabled = False

Set Libro = AppExcel.Workbooks.Add
Set Hoja = Libro.Worksheets(1)

Libro.Title = IIf(szBookTitle = "", "Libro Exportado", szBookTitle)
Libro.Author = "CompWin 2"
Hoja.Name = IIf(szTitle = "", "Libro Exportado", szSheetTitle)

'Aquí van los títulos de las Columnas
CeldaActual = 1
For Columna = 1 To ParamList.ColumnHeaders.Count
    Hoja.Cells(CeldaActual, Columna).Font.Bold = True
    Hoja.Cells(CeldaActual, Columna).Value =
ParamList.ColumnHeaders(Columna).Text
    Hoja.Cells(CeldaActual, Columna).Borders.LineStyle = xltick
    Hoja.Cells(CeldaActual, Columna).Style.IncludeAlignment = True
Next Columna

CeldaActual = 3 'Dejamos un espacio para que quede bonito
ItemActual = 1

While ItemActual <= ParamList.ListItems.Count And gAnularProceso = False

For Columna = 1 To ParamList.ColumnHeaders.Count - 1
        valor = ""
        aux1 = ""
        aux2 = ""
        If Columna = 1 Then Hoja.Cells(CeldaActual, Columna).Value =
CStr(ParamList.ListItems(ItemActual))
        valor = ParamList.ListItems(ItemActual).SubItems(Columna)

texto = False
        If IsNumeric(valor) Then ' se desformtea, es un importe
          'a no ser que sea un objeto
          If Mid(valor, 5, 1) = "." And Mid(valor, 7, 1) = "." Then
            valor = CStr(valor)
          Else
            'si el cuarto caracter por la izqda desde los decimales es un
'.',
            'entonces es númerico, sino, se trata de un texto númerico
            If InStr(1, valor, ",", vbTextCompare) Then
              If Mid(valor, Abs(Len(valor) - (4 + (Len(valor) - _
                InStr(1, valor, ",", vbTextCompare)))), 1) = "." Then
                'valor = TextoGrabarImporte(valor)
                valor = CDec(valor)
              Else
                texto = True 'valor = CDbl(valor)
              End If
            Else
              If Len(valor) > 3 Then
                If Mid(valor, Len(valor) - 3, 1) = "." Then
                  'valor = TextoGrabarImporte(valor)
                  valor = CDec(valor)
                Else
                    texto = True 'valor = CDbl(valor)
                End If
              End If
            End If

End If

End If
        If IsDate(valor) Then
            aux1 = Mid(valor, 2, 1)
            aux2 = Mid(valor, 3, 1)
            If aux1 = "/" Or aux2 = "/" Then
                'Se pasa como texto, así es la única forma
                'de que excel no lo interprete como fecha
                Fecha = Mid(valor, 7, 4)
                aux1 = Mid(valor, 1, 2)
                aux2 = Mid(valor, 4, 2)
                valor = aux1 & "/" & aux2 & "/" & Fecha
                valor = CStr(valor)
            End If
        End If
        If IsDate(valor) Then
            Hoja.Cells(CeldaActual, Columna + 1).Value = "'" & valor
        Else
            If texto Then
                Hoja.Cells(CeldaActual, Columna + 1).Value = "'" & valor
            Else
                Hoja.Cells(CeldaActual, Columna + 1).Value = valor
            End If
        End If
        DoEvents ' Por si decide cancelar el proceso.
    Next Columna
    CeldaActual = CeldaActual + 1
    ItemActual = ItemActual + 1
Wend

AppExcel.Visible = True
  AppActivate AppExcel.Caption

Set Hoja = Nothing      'Descargamos los Objetos...
Set Libro = Nothing
Set AppExcel = Nothing

ParamList.Parent.Enabled = True
Screen.MousePointer = vbNormal

ExportHandlerError:

If Err <> 0 Then
    If Err = 429 Then ' Esto salta al no poder crear el objeto.
        MsgBox "Debe tener instalado Microsoft Excel para poder efectuar la
Exportación...", vbCritical
      Else
        MsgBox "Error número: " & Err.Number & vbCrLf & Err.Description
    End If
End If

End Sub