LViewToExcell

Private Sub ExportRecords(vntData As Variant, _
        vntHeader As Variant, ws As Worksheet)
    Dim lngRow As Long
    Dim intCol As Integer
    Dim varData As Variant
    Dim intStart As Integer
    'Select all Cells and and set the number format to string
    ws.Cells.Select
    ws.Cells.NumberFormat = "@"
    ws.Cells(1, 1).Select
    lngRow = UBound(vntData, 2) + 2
    intCol = UBound(vntData, 1) + 1
    intStart = 2'Start from line 2
    'Freeze Row 2
    ws.Rows(2).Select
    ws.Activate
    ActiveWindow.FreezePanes = True
    'Add Headers
    For x = 1 To intCol
        varData = vntHeader(x - 1)
        ws.Cells(1, x) = CStr(varData)
        ws.Cells(1, x).Font.Bold = True
    Next
    'Add Data
    For y = 1 To intCol
        For x = intStart To lngRow
            varData = vntData(y - 1, x - 2)
            'Make sure no null values, Excel will choke
            If IsNull(varData) Then
                'Add 1 to Move down a column
                ws.Cells(x + 1, y) = ""
            Else
                'Convert To String to preserve formatting
                ws.Cells(x + 1, y) = CStr(varData)
            End If
        Next
    Next
    'Resize Columns to Fit
    ws.Columns.AutoFit
End Sub

Private Sub OpenExcel(vntData As Variant, vntHeader As Variant)
    On Error Goto Err_OpenExcel
    Dim objExcel As Excel.Application
    Dim objWrkSht As Worksheet
    Dim x As Integer
    'Create Excel Object
    Set objExcel = CreateObject("Excel.Application")
    'Add the Workbook
    objExcel.Workbooks.Add
    Set objWrkSht = objExcel.ActiveWorkbook.Sheets(1)
    objExcel.Visible = True
    'Fill the Workbook with data
    ExportRecords vntData, vntHeader, objWrkSht
    objExcel.Interactive = True
    'Clean up:
    Set objExlSht = Nothing
    Set objExcel = Nothing
    Err_OpenExcel:
    Select Case Err
        Case 0
        Case 439
            MsgBox "You must have Microsoft Excel installed" _
                On your PC.", vbCritical, "Application Not Found"
        Case Else
            MsgBox Err & ": " & Error, vbCritical, _
                "OpenExcel Error"
    End Select
End Sub

Referenziare l'oggetto MS Excel nel progetto

Public Sub ExportListViewtoExcel(lvwList As Control)
Dim vntHeader As Variant
Dim vntData As Variant
Dim x As Long
Dim y As Long
Dim intCol As Integer
Dim lngRow As Long
'Get Counts

intCol = CInt(lvwList.ColumnHeaders.Count - 1)
lngRow = CLng(lvwList.ListItems.Count - 1)
ReDim vntHeader(0)
ReDim vntData(intCol, lngRow)
'Create Header Array

For x = 0 To intCol
ReDim Preserve vntHeader(x)
vntHeader(x) = lvwList.ColumnHeaders(x + 1).Text
Next
'Create Data Array

For x = 0 To lngRow
vntData(0, x) = lvwList.ListItems.Item(x + 1).Text
For y = 1 To intCol
vntData(y, x) = lvwList.ListItems.Item(x + 1).SubItems(y)
Next
Next
'Create Excel Object

OpenExcel vntData, vntHeader
End Sub

Private Sub ExportRecords(vntData As Variant, _
vntHeader As Variant, ws As Worksheet)
Dim lngRow As Long
Dim intCol As Integer
Dim varData As Variant
Dim intStart As Integer
'Select all Cells and and set the number format to string

ws.Cells.Select
ws.Cells.NumberFormat = "@"
ws.Cells(1, 1).Select
lngRow = UBound(vntData, 2) + 2
intCol = UBound(vntData, 1) + 1
intStart = 2'Start from line 2
'Freeze Row 2

ws.Rows(2).Select
ws.Activate
ActiveWindow.FreezePanes = True
'Add Headers

For x = 1 To intCol
varData = vntHeader(x - 1)
ws.Cells(1, x) = CStr(varData)
ws.Cells(1, x).Font.Bold = True
Next
'Add Data

For y = 1 To intCol
For x = intStart To lngRow
varData = vntData(y - 1, x - 2)
'Make sure no null values, Excel will choke

If IsNull(varData) Then
'Add 1 to Move down a column

ws.Cells(x + 1, y) = ""
Else
'Convert To String to preserve formatting

ws.Cells(x + 1, y) = CStr(varData)
End If
Next
Next
'Resize Columns to Fit

ws.Columns.AutoFit
End Sub

Private Sub OpenExcel(vntData As Variant, vntHeader As Variant)
On Error Goto Err_OpenExcel
Dim objExcel As Excel.Application
Dim objWrkSht As Worksheet
Dim x As Integer
'Create Excel Object

Set objExcel = CreateObject("Excel.Application")
'Add the Workbook

objExcel.Workbooks.Add
Set objWrkSht = objExcel.ActiveWorkbook.Sheets(1)
objExcel.Visible = True
'Fill the Workbook with data

ExportRecords vntData, vntHeader, objWrkSht
objExcel.Interactive = True
'Clean up:

Set objExlSht = Nothing
Set objExcel = Nothing
Err_OpenExcel:
Select Case Err
Case 0
Case 439
MsgBox "You must have Microsoft Excel installed" _
On your PC.", vbCritical, "Application Not Found"
Case Else
MsgBox Err & ": " & Error, vbCritical, _
"OpenExcel Error"
End Select
End Sub

Referenziare l'oggetto MS Excel nel progetto