- 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
Semoga bermanfaat.. ^_
0 komentar:
Posting Komentar