Export listview vb6 | Database Access Ke Excel

Assalamualaikum wr.wb
Beberapa Fungsi dari listview sudah saya tampilkan dipostingan sebelumnya, sekarang saya menemukan hal yang baru buat saya, yaitu Export data yang ada listview ke Excel, mungkin hal ini penting gak penting tetapi akan sangat dibutuhkan apabila sobat mau cross check hasil dari input user tanpa harus buka program aplikasinya.

“Disc space computer saya sudah penuh, tak simpan disini saja”

Dari pada panjang lebar ---> Berikut
Source Codenya :

Sub Export()

On Error Resume Next

Screen.MousePointer = vbHourglass

Dim Rfs As Integer

Dim LstFld As Integer

Dim exc As New Excel.Application

Dim wb As Excel.Workbook

Dim ws As Excel.Worksheet

Dim k As Integer

Dim CLms As Integer

Dim no As Integer

'On Error GoTo 1

Set wb = exc.Workbooks.Add

Set ws = wb.Worksheets(1)

LstFld = 9   ‘Jumlah Collumn

ws.Cells.Clear

exc.Visible = True '<---- Merubah dari “ False” Export ke excel data

'On Error GoTo 1

For CLms = 1 To LstFld

ws.Cells(1, CLms).Font.Bold = True '<-- Bold

ws.Cells(1, CLms) = Me.Listview1.ColumnHeaders(CLms).Text '<---Menambahkan ListViewer column headers ke XL Sheet

ws.Cells(1, CLms).Font.Color = &H8000& '<--- Warna Hijau

ws.Cells(1, CLms).Interior.Color = vbGreen

Next CLms

‘Menampilkan criteria selection

ws.Cells(2, 2) = "Selection : ******************"

ws.Cells(3, 2) = "Tanggal : ***" & Format(D1, "dd/mm/yyyy") & " --- s/d --- " & Format(D2, "dd/mm/yyyy")

ws.Cells(4, 2) = "Kelompok : ***" & Combo1.Text & ",----- Item --- : " & T1.Text & " - " & Label5.Caption

ws.Cells(2, 2).Font.Color = &H808000

ws.Cells(3, 2).Font.Color = &H808000

ws.Cells(4, 2).Font.Color = &H808000

Dim flds As Integer

Dim flds2 As Integer

Dim strFlds As String

flds2 = LstFld

For i = 1 To TraceItem.ListItems.Count

    strFlds = ""

    strFlds = Me.TraceItem.ListItems(i).Text

    ws.Cells(i + 5, 1) = strFlds '<--- data export ke Excel sheet

    For flds = 1 To flds2

    strFlds = ""

    strFlds = Me.TraceItem.ListItems(i).ListSubItems(flds).Text

    ws.Cells(i + 5, flds + 1) = strFlds '<--- data export to Excel sheet

    Next flds

Next i

    'For CLms = 1 To LstFld

    ws.Columns(1).AutoFit '<---Autofilt data on XL sheet

    'Next CLms

‘Menampilkan data non listview

ws.Cells(Me. Listview1.ListItems.Count + 8, 1) = "" '<---Bemberikan jarak pada baris terakhir

ws.Cells(Me. Listview1.ListItems.Count + 9, 2) = "Software by: Agoes Priyanto bocah Sragen"

ws.Cells(Me. Listview1.ListItems.Count + 10, 2) = "Export Data tanggal" & " " & Format(Now, "dd.mm.yyyy")

Dim clms1 As Integer

For clms1 = 1 To 9

ws.Cells(Me. Listview1.ListItems.Count + 8, 2).Font.Bold = True '<-- Bold

ws.Cells(Me. Listview1.ListItems.Count + 8, 2).Font.Color = &H808000 '<--- Green Color

ws.Cells(Me. Listview1.ListItems.Count + 9, 2).Font.Bold = True

ws.Cells(Me. Listview1.ListItems.Count + 9, 2).Font.Color = &H808000 '<--- Green Color

ws.Cells(Me. Listview1.ListItems.Count + 10, 2).Font.Bold = True

ws.Cells(Me. Listview1.ListItems.Count + 10, 2).Font.Color = &H808000 '<--- Green Color

Next clms1

    ws.Name = Me. Listview1.Name '<----Nama Sheet



    exc.Visible = True '<--- Membuka Excel sheet setelah Export

    Set wb = Nothing ‘Mengembalikan ke nilai awal

    Set ws = Nothing ‘Mengembalikan ke nilai awal



'1:

'MsgBox Err.Description, vbCritical, "Error " & Err.Number

Screen.MousePointer = vbDefault

Exit Sub

End Sub

Hasil dari Export seperti gambar :

Semoga bermanfaat
Link Download Contoh Project Disini (Office Excel)
Link Download Contoh Project Disini (Spreadsheet 2012)

Wassalamualaikum wr.wb

Link Download Contoh project, [.dll],[.ocx]