Memunculkan Field Gambar(OLE Object) Di Database Acces

Sedikiit berbagi lagi.. Mungkin Teman2 ada kesulitan mengenai memunculkan file Image Database Acces ke VB. Saya menggunakan dua Cara untuk mewujudkan hal tersebut:

1. Me-Load Gambar dalam Kontrol Image dari String Alamat Gambar yang telah ada di Field Database, jadi Field dalam tabel bertype Text. Keuntungannya Database berukuran lebih Kecil dibanding cara kedua.
2. Meload Gambar Dari Field yang bertype OLE Object kedalam kontrol Image. Keuntungannya semua gambar dalam satu database sehingga dapat sebagai pustaka gambar.

Kali ini kita akan menggunakan cara yang kedua, Buat Database Acces bernama "BioData.mdb" terdiri atas satu Tabel yaitu "TblPhotoSaja" dan di dalamnya buat field Type Ole Object beri nama "Image",serta satu field lagi Bertype AutoNumber berinama "Id", Langsung saja ^_^ ini saourcenya..

Copy Paste Code Dibawah Ini Dalam form

Option Explicit
Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
Private Declare Function lOpen Lib "kernel32" Alias "_lopen" (ByVal lpPathName As String, ByVal iReadWrite As Long) As Long
Private Declare Function lclose Lib "kernel32" Alias "_lclose" (ByVal hFile As Long) As Long
Private Declare Function GetFileSize Lib "kernel32" (ByVal hFile As Long, lpFileSizeHigh As Long) As Long
Private lpFSHigh As Long
Private strfilepath As String
Private Buffer As String
Private Const OF_READ = &H0&
Private db As ADODB.Connection
Private WithEvents adoPrimaryRSImageName As Recordset

Private Type OPENFILENAME
    lStructSize As Long
    hwndOwner As Long
    hInstance As Long
    lpstrFilter As String
    lpstrCustomFilter As String
    nMaxCustFilter As Long
    nFilterIndex As Long
    lpstrFile As String
    nMaxFile As Long
    lpstrFileTitle As String
    nMaxFileTitle As Long
    lpstrInitialDir As String
    lpstrTitle As String
    Flags As Long
    nFileOffset As Integer
    nFileExtension As Integer
    lpstrDefExt As String
    lCustData As Long
    lpfnHook As Long
    lpTemplateName As String
End Type

Private Function GetFile(ByRef frm As Form) As String
    Dim OFName As OPENFILENAME
    OFName.lStructSize = Len(OFName)
    'Set the parent window
    OFName.hwndOwner = frm.hWnd
    'Set the application's instance
    OFName.hInstance = App.hInstance
    'Select a filter
    OFName.lpstrFilter = "Bitmap (*.bmp)" + Chr$(0) + _
      "*.bmp" + Chr$(0) + _
      "Jpg (*.jpg)" + Chr$(0) + _
      "*.jpg" + Chr$(0) + _
      "Icons (*.ico)" + Chr$(0) + _
      "*.ico" + Chr$(0) + _
      "Windows Metafiles (*.wmf)" + Chr$(0) + _
      "*.wmf" + Chr$(0) + _
      "Jpeg (*.jpeg)" + Chr$(0) + _
      "*.jpeg" + Chr$(0) + _
      "Gif (*.gif)" + Chr$(0) + _
      "*.gif" + Chr$(0) + _
      "All Files (*.*)" + Chr$(0) + _
      "*.*" + Chr$(0)
    'create a buffer for the file
    OFName.lpstrFile = Space$(254)
    'set the maximum length of a returned file
    OFName.nMaxFile = 255
    'Create a buffer for the file title
    OFName.lpstrFileTitle = Space$(254)
    'Set the maximum length of a returned file title
    OFName.nMaxFileTitle = 255
    'Set the initial directory
    'OFName.lpstrInitialDir = "C:\" 'Commented so that the box opens on the last directory browsed
    'Set the title
    OFName.lpstrTitle = "Open Dialog Box"
    'No flags
    OFName.Flags = 0
    'Show the 'Open File'-dialog
    If GetOpenFileName(OFName) Then
      GetFile = Trim$(OFName.lpstrFile)
    Else
      GetFile = ""
    End If
End Function

Private Sub SaveBitmap(ByRef adoRS As ADODB.Recordset, ByVal strField As String, ByVal SourceFile As String)
    'This sub copies the actual file into a byte array.
    'This byte array is then used as the value for
    'the field having an image data type
    Dim Arr() As Byte
    Dim Pointer As Long
    Dim SizeOfThefile As Long
    Pointer = lOpen(SourceFile, OF_READ)
    'size of the file
    SizeOfThefile = GetFileSize(Pointer, lpFSHigh)
    lclose Pointer
    'Resize the array, then fill it with
    'the entire contents of the field
    ReDim Arr(SizeOfThefile)
    Open SourceFile For Binary Access Read As #1
    Get #1, , Arr
    Close #1
    adoRS(strField).Value = Arr
    Exit Sub
End Sub

Private Sub cmdFirst_Click()
If adoPrimaryRSImageName.BOF And adoPrimaryRSImageName.RecordCount = 0 Then
   MsgBox "Anda Tidak Memiliki Data Record, Klik Tombol " & """" & "Tambah Record" & """" & " untuk Membuat Record."
Else
  adoPrimaryRSImageName.MoveFirst
End If
End Sub

Private Sub cmdLast_Click()
If adoPrimaryRSImageName.EOF And adoPrimaryRSImageName.RecordCount = 0 Then
   MsgBox "Anda Tidak Memiliki Data Record."
Else
    adoPrimaryRSImageName.MoveLast
End If
End Sub

Private Sub cmdNext_Click()
If adoPrimaryRSImageName.EOF And adoPrimaryRSImageName.RecordCount = 0 Then
   MsgBox "Anda Tidak Memiliki Data Record."
End If
If Not adoPrimaryRSImageName.EOF Then adoPrimaryRSImageName.MoveNext
If adoPrimaryRSImageName.EOF And Not adoPrimaryRSImageName.RecordCount = 0 Then
    Beep
    adoPrimaryRSImageName.MoveLast
End If
End Sub

Private Sub cmdPrevious_Click()
If adoPrimaryRSImageName.BOF And adoPrimaryRSImageName.RecordCount = 0 Then
   MsgBox "Anda Tidak Memiliki Data Record"
End If
If Not adoPrimaryRSImageName.BOF Then adoPrimaryRSImageName.MovePrevious
If adoPrimaryRSImageName.BOF And Not adoPrimaryRSImageName.RecordCount = 0 Then
    Beep
    adoPrimaryRSImageName.MoveFirst
End If
End Sub

Private Sub CariSimpanImage_Click()
    strfilepath = GetFile(Me)
    If strfilepath <> "" Then
        Image1.Picture = LoadPicture(strfilepath)
        SaveBitmap adoPrimaryRSImageName, "Image", strfilepath
    End If
End Sub

Sub Koneksi()
    Set db = New ADODB.Connection
    db.CursorLocation = adUseClient
    db.Open "PROVIDER=Microsoft.Jet.OLEDB.4.0;" & _
      "Data Source=" & App.Path & "\BioData.mdb"
    Set adoPrimaryRSImageName = New ADODB.Recordset
    adoPrimaryRSImageName.Open "TblPhotoSaja", db, adOpenDynamic, adLockOptimistic
    Set Image1.DataSource = adoPrimaryRSImageName
End Sub

Private Sub Form_Load()
    Koneksi
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Set db = Nothing
    Set adoPrimaryRSImageName = Nothing
    Unload Me
End Sub

Semoga bermanfaat.. ^_^