Disini saya tidak akan menjelaskan bagaimana melakukan koneksi ke database access, intinya aplikasi Anda sudah siap menjalankan perintah SELECT, INSERT, UPDATE, dan DELETE. Jika Anda masih kesulitan bisa dilihat disini.
Untuk kasus disini kita akan menyimpan data mahasiswa dengan tiga field saja, lihat gambar berikut :
Khusus untuk field foto tipe yang dipilih adalah OLE Object, kita langsung aja copy paste kode berikut di module :
Option Explicit
Public Const CHUNK_SIZE As Long = 16384
Dim rsImage As ADODB.Recordset
Dim i As Long
Dim lsize As Long
Dim iChunks As Long
Dim nFragmentOffset As Long
Dim lchunks As Long
Dim nHandle As Integer
Dim varChunk() As Byte
Public Function fileExists(ByVal strNamaFile As String) As Boolean
If Not (Len(strNamaFile) > 0) Then fileExists = False: Exit Function
If Dir$(strNamaFile, vbNormal) = "" Then
fileExists = False
Else
fileExists = True
End If
End Function
Public Sub closeRecordset(ByVal vRs As ADODB.Recordset)
On Error Resume Next
If Not (vRs Is Nothing) Then
If vRs.State = adStateOpen Then
vRs.Close
Set vRs = Nothing
End If
End If
End Sub
Public Function addImageToDB(ByVal query As String, ByVal imageName As String, ByVal imageField As String) As Boolean
On Error GoTo errHandle
Set rsImage = New ADODB.Recordset
rsImage.Open query, conn, adOpenKeyset, adLockOptimistic
If Not rsImage.EOF Then
nHandle = FreeFile
Open imageName For Binary Access Read As nHandle
lsize = LOF(nHandle)
If nHandle = 0 Then Close nHandle
lchunks = lsize / CHUNK_SIZE
nFragmentOffset = lsize Mod CHUNK_SIZE
ReDim varChunk(nFragmentOffset)
Get nHandle, , varChunk()
rsImage(imageField).AppendChunk varChunk()
ReDim varChunk(CHUNK_SIZE)
For i = 1 To lchunks
Get nHandle, , varChunk()
rsImage(imageField).AppendChunk varChunk()
DoEvents
Next
rsImage.Update
End If
Call closeRecordset(rsImage)
addImageToDB = True
Exit Function
errHandle:
addImageToDB = False
End Function
Public Function getImageFromDB(ByVal query As String) As IPictureDisp
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
Set getImageFromDB = LoadPicture(sFile, , vbLPColor)
Else
Set getImageFromDB = Nothing
End If
Else
Set getImageFromDB = Nothing
End If
Call closeRecordset(rsImage)
Exit Function
errHandle:
Set getImageFromDB = Nothing
End Function
Untuk di form cukup dengan kode sederhana berikut :
123456789101112131415
Private Sub cmdSimpan_Click()
'untuk format gambar bisa JPG atau BMP
strSql = "INSERT INTO mhs (nim, nama) VALUES ('" & txtNIM.Text & "', '" & txtNama.Text & "')"
conn.Execute strSql
If fileExists(txtLokasiFoto.Text) Then
strSql = "SELECT nim, foto FROM mhs WHERE nim = '" & txtNIM.Text & "'"
If Not addImageToDB(strSql, txtLokasiFoto.Text, "foto") Then MsgBox "Foto mahasiswa gagal disimpan !"
End If
End Sub
Private Sub cmdTampil_Click()
strSql = "SELECT foto FROM mhs WHERE nim = '" & txtNIM.Text & "'"
Set picMhs.Picture = getImageFromDB(strSql)
End Sub
