Export to Excel

Private Sub cmdExport_Click()

Dim rs As ADODB.Recordset
 
   On Error GoTo halt
   Me.MousePointer = 11
 
    Dim Answer As VbMsgBoxResult
       
    Priod = txtPriod.Text
    KdSem = txtKdSem.Text
   
    'Set Recordset(rdoCon) [Proses Query]
    Set rs = Nothing
    query = "[stored Procedure]'" _
            & Priod & "','" _
            & KdSem & "','" _
            & IIf(cmbLokasi.Text = "All", 0, Left(cmbLokasi.Text, 1)) & "','" _
            & IIf(cmbGugusBinaan.Text = "All", 0, Left(cmbGugusBinaan.Text, 2)) & "','" _
            & IIf(cmbMatkul.Text = "All", 0, Left(cmbMatkul.Text, 5)) & "',1"
    Set rs = Puskom.gadocon.Execute(query)
   
    'Jika tidak ada data, tampilkan pesan, dan disable btnSave & chkAll
    If rs.EOF Then
        If showErrIfNull = True Then
            Answer = MsgBox("Data Tidak Ada", vbExclamation, "Informasi")
        End If
    End If

     
Dim oExcelApp As Object
    Dim oExcelWkb As Object
    Dim oExcelWks As Object
    Dim i As Integer
    Dim cnt As Integer
    Dim iRow As Integer
    Me.MousePointer = 11
            Set oExcelApp = CreateObject("Excel.Application")
            Set oExcelWkb = oExcelApp.Workbooks.Add
            Set oExcelWks = oExcelWkb.worksheets(1)
       
        'what to be writed
'            createExcelData oExcelWks, rs
     
            oExcelWks.Cells(1, 1).Value = "No"
            oExcelWks.Cells(1, 2).Value = "Lokasi"
            oExcelWks.Cells(1, 3).Value = "Gugus"
            oExcelWks.Cells(1, 4).Value = "Matakuliah"
            oExcelWks.Cells(1, 5).Value = "Kelas"
            oExcelWks.Cells(1, 6).Value = "Jml Mhs"
       
            For i = 1 To 6
                oExcelWks.Columns(i).autofit
                oExcelWks.Cells(1, i).Font.Bold = True
                'BuatKotak oExcelApp, i, 1
            Next i
           
            cnt = 2
            iRow = 1
            If Not rs.EOF Then rs.MoveFirst
            Do While Not rs.EOF
                oExcelWks.Cells(cnt, 1).Value = iRow
                oExcelWks.Cells(cnt, 2).Value = rs!Lokasi
                oExcelWks.Cells(cnt, 3).Value = rs!gugus
                oExcelWks.Cells(cnt, 4).Value = rs!Matkul
                oExcelWks.Cells(cnt, 5).Value = rs!kelas
                oExcelWks.Cells(cnt, 6).Value = rs!jmmhs
                rs.MoveNext
                cnt = cnt + 1
                iRow = iRow + 1
            Loop
       
            For i = 1 To 5
                oExcelWks.Columns(i).autofit
                'BuatKotak oExcelApp, i, 2, i, cnt - 1
            Next i
       
        'end of what tobe writed
       
            oExcelWkb.SaveAs "C:\Documents and Settings\All Users\Desktop\InformasiKelasSmartProgram.xls", FileFormat:=56
               
            oExcelApp.quit
       
            Set oExcelApp = Nothing
            Set oExcelWkb = Nothing
            Set oExcelWks = Nothing
       
            Me.MousePointer = 0
            MsgBox "File Excel Created Sucessfuly", , Me.Caption
            Exit Sub
halt:
   Set rs = Nothing
   Me.MousePointer = 0
   MsgBox err.Description, vbCritical, "Error"
End Sub