Membuat laporan dalam format Ms Excel plus ada gambarnya

Artikel ini ditulis berdasarkan beberapa artikel favorit di blog ini , yaitu artikel INI dan ITU.

Inti pembahasan artikel kali ini adalah menampilkan gambar yang disimpan di database ke Ms Excel.

Untuk contoh disini kita akan menampilkan data siswa (nis, nama, alamat plus fotonya).

Ada banyak cara untuk menampilkan gambar di Ms Excel salah satunya dengan menggunakan prosedur berikut :

Private Sub addImage(ByVal objWBook As Object, ByVal imageName As String, ByVal kolom As String, ByVal iRow As Long, _
                    ByVal width As Double, ByVal height As Double, _
                    Optional minTop As Integer = 10, Optional plusLeft As Integer = 16, Optional worksheet As Long = 1)

    Dim objPict As Object

    Set objPict = objWBook.Worksheets(worksheet).Pictures.Insert(imageName)
    With objPict
        .Top = objWBook.Worksheets(worksheet).Range(kolom & iRow).Top - minTop
        .Left = objWBook.Worksheets(worksheet).Range(kolom & iRow).Left + plusLeft
        .width = width
        .height = height
    End With
    Set objPict = Nothing
End Sub

Kemudian untuk mengambil data berupa gambar dari database, prosedur yang digunakan adalah sebagai berikut :

Public Function getImageFromDB(ByVal query As String) As String
    Dim sFile           As String

    On Error GoTo errHandle

    Set rsImage = New ADODB.Recordset
    rsImage.Open query, conn, adOpenForwardOnly, adLockReadOnly
    If Not rsImage.EOF Then
        If Not IsNull(rsImage(0).Value) Then
            nHandle = FreeFile

            sFile = App.Path & "\output.bin"
            If fileExists(sFile) Then Kill sFile
            DoEvents

            Open sFile For Binary Access Write As nHandle

            lsize = rsImage(0).ActualSize
            iChunks = lsize \ CHUNK_SIZE
            nFragmentOffset = lsize Mod CHUNK_SIZE

            varChunk() = rsImage(0).GetChunk(nFragmentOffset)
            Put nHandle, , varChunk()
            For i = 1 To iChunks
                 ReDim varChunk(CHUNK_SIZE) As Byte

                 varChunk() = rsImage(0).GetChunk(CHUNK_SIZE)
                 Put nHandle, , varChunk()
                 DoEvents
            Next
            Close nHandle

            getImageFromDB = sFile
        End If
    End If
    Call closeRecordset(rsImage)

    Exit Function
errHandle:
    getImageFromDB = ""
End Function

Prosedur diatas merupakan revisi dari prosedur yang ada di artikel sebelumnya, perbedaannya hanya terletak pada return value (nilai kembaliannya) jika pada artikel sebelumnya return valuenya bertipe IPictureDisp sedang revisi prosedur pada artikel ini bertipe String.

Terakhir untuk mengekspor ke Ms Excel sekaligus contoh penggunaan ke dua prosedur diatas adalah sebagai berikut :

Private Sub cmdEkspor_Click()
    Dim rs          As ADODB.Recordset

    Dim objExcel    As Object
    Dim objWBook    As Object
    Dim objWSheet   As Object

    Dim initRow     As Long
    Dim strSql      As String

    On Error GoTo errHandle

    Screen.MousePointer = vbHourglass
    DoEvents

    'Create the Excel object
    Set objExcel = CreateObject("Excel.application") 'bikin object

    'Create the workbook
    Set objWBook = objExcel.Workbooks.Add

    Set objWSheet = objWBook.Worksheets(1)
    With objWSheet
        initRow = 5

        strSql = "SELECT * FROM siswa"
        Set rs = conn.Execute(strSql)
        If Not rs.EOF Then
            Do While Not rs.EOF
                .cells(initRow, 5) = "NIS"
                .cells(initRow, 6) = ": " & rs("nis").Value

                .cells(initRow + 1, 5) = "Nama"
                .cells(initRow + 1, 6) = ": " & rs("nama").Value

                .cells(initRow + 2, 5) = "Alamat"
                .cells(initRow + 2, 6) = ": " & rs("alamat").Value

                strSql = "SELECT foto FROM siswa WHERE nis = '" & rs("nis").Value & "'"
                Call addImage(objWBook, getImageFromDB(strSql), "C", initRow, 45, 51, 12, 48)

                initRow = initRow + 5
                rs.MoveNext
            Loop
        End If
        Call closeRecordset(rs)
    End With

    objExcel.Visible = True

    If Not objWSheet Is Nothing Then Set objWSheet = Nothing
    If Not objWBook Is Nothing Then Set objWBook = Nothing
    If Not objExcel Is Nothing Then Set objExcel = Nothing

    Screen.MousePointer = vbDefault

    Exit Sub

errHandle:
    If Not objWSheet Is Nothing Then Set objWSheet = Nothing
    If Not objWBook Is Nothing Then Set objWBook = Nothing
    If Not objExcel Is Nothing Then Set objExcel = Nothing
End Sub

Contoh hasil ekspor

Selamat mencoba