Artikel ini ditulis berdasarkan beberapa artikel favorit di blog ini :D, 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 :
123456789101112131415
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
