Sedikiit berbagi lagi.. Mungkin Teman2 ada kesulitan mengenai memunculkan file Image Database Acces ke VB. Saya menggunakan dua Cara untuk mewujudkan hal tersebut:
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..
- 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.
- Meload Gambar Dari Field yang bertype OLE Object kedalam kontrol Image. Keuntungannya semua gambar dalam satu database sehingga dapat sebagai pustaka gambar.
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
Posted in:
komputer
