APLIKASI RAB ( RENCANA ANGGARAN BIAYA ) OPEN SOURCE

APLIKASI DIBUAT DENGAN VISUAL BASIC 6.0 DENGAN DATABASE M ACCSESS BERIKUT CONTOH GAMBAR DALAM MODE JPG :

MEMBUAT APLIKASI PINDAH DATABASE KE EXCEL DENGAN VISUAL BASIC 6.0

Berikut source kode :

Option Explicit
Dim con As ADODB.Connection
Dim rec As ADODB.Recordset
Dim connectString As String
Dim objExcel As Object
Dim objTemp As Object

Public Sub excel(rec As ADODB.Recordset)
  Dim indexbaris As Integer
  Dim indexcolom As Integer
  Dim jmlrecord As Integer
  Dim jmlfield As Integer
  Dim totalbaris As Variant
  Dim excelVersion As Integer

  totalbaris = rec.GetRows()

  jmlrecord = UBound(totalbaris, 2) + 1
  jmlfield = UBound(totalbaris, 1) + 1

  Set objExcel = CreateObject("Excel.Application")
  objExcel.Visible = True
  objExcel.Workbooks.Add

  Set objTemp = objExcel
  excelVersion = Val(objExcel.Application.Version)
  If (excelVersion >= 8) Then
    Set objExcel = objExcel.ActiveSheet
  End If

  indexbaris = 1
  indexcolom = 1
  For indexcolom = 1 To jmlfield
    With objExcel.Cells(indexbaris, indexcolom)
      .Value = rec.Fields(indexcolom - 1).Name
      With .Font
        .Name = "Tahoma"
        .Bold = True
        .Size = 8
      End With
    End With
  Next

  rec.Close
  Set rec = Nothing

  With objExcel
    For indexbaris = 2 To jmlrecord + 1
      For indexcolom = 1 To jmlfield
        .Cells(indexbaris, indexcolom).Value = totalbaris(indexcolom - 1, indexbaris - 2)
      Next
    Next
  End With

  objExcel.Cells(1, 1).CurrentRegion.EntireColumn.AutoFit
End Sub

Private Sub Form_Activate()
  Dim SqlString As String

  Set con = New ADODB.Connection
  Set rec = New ADODB.Recordset

  connectString = "Provider=Microsoft.Jet.OLEDB.3.51;" _
                 & "Data Source=D:\LATIHAN\VB6\lat_1.mdb"   ( ket : sesuaikan dengan database anda yag dibuat )

  SqlString = "SELECT * FROM Publishers where PubID <= 50"

  con.Open connectString
  rec.CursorLocation = adUseClient
  rec.Open SqlString, con
End Sub

Private Sub Command1_Click()
  Call excel(rec)
End Sub