Membuat laporan dalam format Ms Excel plus ada gambarnya

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 :

01	Private Sub addImage(ByVal objWBook As Object, ByVal imageName As String, ByVal kolom As String, ByVal iRow As Long, _

02	ByVal width As Double, ByVal height As Double, _

03	Optional minTop As Integer = 10, Optional plusLeft As Integer = 16, Optional worksheet As Long = 1)

04

05	Dim objPict As Object

06

07	Set objPict = objWBook.Worksheets(worksheet).Pictures.Insert(imageName)

08	With objPict

09	.Top = objWBook.Worksheets(worksheet).Range(kolom & iRow).Top - minTop

10	.Left = objWBook.Worksheets(worksheet).Range(kolom & iRow).Left + plusLeft

11	.width = width

12	.height = height

13

End With

14	Set objPict = Nothing

15

End Sub

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

01	Public Function getImageFromDB(ByVal query As String) As String

02	Dim sFile           As String

03

04	On Error GoTo errHandle

05

06	Set rsImage = New ADODB.Recordset

07	rsImage.Open query, conn, adOpenForwardOnly, adLockReadOnly

08	If Not rsImage.EOF Then

09	If Not IsNull(rsImage(0).Value) Then

10	nHandle = FreeFile

11

12	sFile = App.Path & "\output.bin"

13	If fileExists(sFile) Then Kill sFile

14

DoEvents

15

16	Open sFile For Binary Access Write As nHandle

17

18	lsize = rsImage(0).ActualSize

19	iChunks = lsize \ CHUNK_SIZE

20	nFragmentOffset = lsize Mod CHUNK_SIZE

21

22	varChunk() = rsImage(0).GetChunk(nFragmentOffset)

23	Put nHandle, , varChunk()

24	For i = 1 To iChunks

25	ReDim varChunk(CHUNK_SIZE) As Byte

26

27	varChunk() = rsImage(0).GetChunk(CHUNK_SIZE)

28	Put nHandle, , varChunk()

29

DoEvents

30

Next

31	Close nHandle

32

33	getImageFromDB = sFile

34

End If

35

End If

36	Call closeRecordset(rsImage)

37

38	Exit Function

39	errHandle:

40	getImageFromDB = ""

41	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 :

01	Private Sub cmdEkspor_Click()

02	Dim rs          As ADODB.Recordset

03

04	Dim objExcel    As Object

05	Dim objWBook    As Object

06	Dim objWSheet   As Object

07

08	Dim initRow     As Long

09	Dim strSql      As String

10

11	On Error GoTo errHandle

12

13	Screen.MousePointer = vbHourglass

14

DoEvents

15

16	'Create the Excel object

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

18

19	'Create the workbook

20	Set objWBook = objExcel.Workbooks.Add

21

22	Set objWSheet = objWBook.Worksheets(1)

23	With objWSheet

24	initRow = 5

25

26	strSql = "SELECT * FROM siswa"

27	Set rs = conn.Execute(strSql)

28	If Not rs.EOF Then

29	Do While Not rs.EOF

30	.cells(initRow, 5) = "NIS"

31	.cells(initRow, 6) = ": " & rs("nis").Value

32

33	.cells(initRow + 1, 5) = "Nama"

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

35

36	.cells(initRow + 2, 5) = "Alamat"

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

38

39	strSql = "SELECT foto FROM siswa WHERE nis = '" & rs("nis").Value & "'"

40	Call addImage(objWBook, getImageFromDB(strSql), "C", initRow, 45, 51, 12, 48)

41

42	initRow = initRow + 5

43	rs.MoveNext

44

Loop

45

End If

46	Call closeRecordset(rs)

47

End With

48

49	objExcel.Visible = True

50

51	If Not objWSheet Is Nothing Then Set objWSheet = Nothing

52	If Not objWBook Is Nothing Then Set objWBook = Nothing

53	If Not objExcel Is Nothing Then Set objExcel = Nothing

54

55	Screen.MousePointer = vbDefault

56

57

Exit Sub

58

59	errHandle:

60	If Not objWSheet Is Nothing Then Set objWSheet = Nothing

61	If Not objWBook Is Nothing Then Set objWBook = Nothing

62	If Not objExcel Is Nothing Then Set objExcel = Nothing

63

End Sub

Contoh hasil ekspor

Selamat mencoba