Uhm ok. I am near n finishing my project (Payroll System)

But im having problems regarding some codes and i am only able to fix some of it

My real problem is the saving of picture in the database.

Have the code, works well but doesn't save the pic as a binary (in my database).

If anyone would be so kind to debug my project.

I'll just upload it

Thanks.

No project loaded?

Show me the code for the actual conversion to binary. It seems your problem is in there.

Enum Connect
    useAdo = 1
    useDao = 2
End Enum



Dim DataFile As Integer, FileLength As Long, Chunks As Integer
Dim SmallChunks As Integer, Chunk() As Byte, i As Integer
Const ChunkSize As Integer = 1024
Public PhotoFileName As String
Public Event OnPhotoSaving(Succeded As Boolean, Filename As String)
Public Event OnPhotoLoading(IsPicture As Boolean, ErrorDescription As String)
'Public Event Click()
Const m_def_ConnectionType = 1
Dim m_ConnectionType As Connect
'Event Declarations:
Event Click() 'MappingInfo=Photo,Photo,-1,Click


Public Sub Reset()
    '---------------------------------------------
    'Clear the Photo picture box
    '---------------------------------------------
    Photo.Picture = LoadPicture("")
End Sub

Public Sub Refresh()
    '---------------------------------------------
    'Load the current imagefile into the picture box
    '---------------------------------------------
    If Len(PhotoFileName) > 0 Then Photo.Picture = LoadPicture(PhotoFileName)
End Sub

Public Function OpenPhotoFile() As String
Dim Filter As String
Dim Filename As String
'On error GoTo Out
    '---------------------------------------------
    'Open a common dialog whitout ocx to browse
    'for an image file
    '---------------------------------------------

    Filter = "Pictures(*.bmp;*.ico;*.gif;*.jpg)|*.bmp;*.ico;*.gif;*.jpg|All Files (*.*)|*.*"
    PhotoFileName = OpenFile(Filter, "Select Photo Image", App.Path)
    OpenPhotoFile = PhotoFileName
    Photo.Picture = LoadPicture(PhotoFileName)
Exit Function
Out:
    MsgBox err.Description
End Function

Public Sub SavePhoto(Fieldname As Field)
Dim rs As Recordset
'On error GoTo Out

'---------------------------------------------
' If there is no image file exits
'---------------------------------------------
If Len(PhotoFileName) = 0 Then Exit Sub
DataFile = 1

'---------------------------------------------
'Open the image file
'---------------------------------------------
Open PhotoFileName For Binary Access Read As DataFile
    FileLength = LOF(DataFile)    ' Length of data in file
    '---------------------------------------------
    'If the imagefile is empty exits
    '---------------------------------------------
    If FileLength = 0 Then
        Close DataFile
        Exit Sub
    End If
    '---------------------------------------------
    'Calculate the bytes(Chunks)pakages to write
    '---------------------------------------------
    Chunks = FileLength \ ChunkSize
    SmallChunks = FileLength Mod ChunkSize
    '---------------------------------------------
    'Resize the chunck array to adjust the firts bytes package
    'To be copied
    '---------------------------------------------
    
    ReDim Chunk(SmallChunks)
    Get DataFile, , Chunk()
    '---------------------------------------------
    'Write the bytes to the given database fieldname
    '---------------------------------------------
    Fieldname.AppendChunk Chunk()
    '---------------------------------------------
    'Adjust the chunck array for the rest bytes
    'packages to be copied
    '---------------------------------------------
    ReDim Chunk(ChunkSize)
    For i = 1 To Chunks
        Get DataFile, , Chunk()
        Fieldname.AppendChunk Chunk()
    Next i
Close DataFile
RaiseEvent OnPhotoSaving(True, PhotoFileName)
Exit Sub
Out:
RaiseEvent OnPhotoSaving(False, PhotoFileName)
End Sub


Public Function LoadPhoto(Fieldname As Field) As String

Dim lngOffset As Long
Dim lngTotalSize As Long
Dim strChunk As String


On Error GoTo Out

DataFile = 1

Open App.Path & "\RscPic.tmp" For Binary Access Write As DataFile
   '============================================
   'Support ado and Dao
   'Choose the right command according to user connection type
   '============================================
   If m_ConnectionType = useAdo Then
        lngTotalSize = Fieldname.ActualSize
    Else
        lngTotalSize = DaoFieldSize(Fieldname)
    End If
    
    Chunks = lngTotalSize \ ChunkSize
    SmallChunks = lngTotalSize Mod ChunkSize
        
        ReDim Chunk(ChunkSize)
            '============================================
            'Support ado and Dao
            'Choose the right command according to user connection type
            '============================================
            
        If m_ConnectionType = useDao Then
            Chunk() = GetDaoChunk(Fieldname)
        Else
            Chunk() = Fieldname.GetChunk(ChunkSize)
        End If
        
        Put DataFile, , Chunk()
        lngOffset = lngOffset + ChunkSize
        
        Do While lngOffset < lngTotalSize
            '============================================
            'Support ado and Dao
            'Choose the right command according to user connection type
            '============================================
            
            If m_ConnectionType = useAdo Then
                 Chunk() = Fieldname.GetChunk(ChunkSize)
            Else
                 Chunk() = GetDaoChunk(Fieldname)
            End If
            Put DataFile, , Chunk()
            lngOffset = lngOffset + ChunkSize
        Loop
Close DataFile
'============================================
' Pass the image file location to the function
'============================================
LoadPhoto = App.Path & "\RscPic.tmp"

'============================================
'Load the picture into the image box
'============================================

Photo.Picture = LoadPicture(App.Path & "\RscPic.tmp")
RaiseEvent OnPhotoLoading(True, "")

Exit Function

Out:
err.Clear
RaiseEvent OnPhotoLoading(False, err.Description)

End Function

'The fallowing function retrieve the fieldsize when
'Using a dao connection
Private Function DaoFieldSize(Fieldname As DAO.Field) As Long
Dim lngOffset As Long
    DaoFieldSize = Fieldname.FieldSize
End Function

'The fallowing function retrieve the Chunk data when
'Using a dao connection
Private Function GetDaoChunk(Fieldname As DAO.Field)
Dim lngOffset As Long
    GetDaoChunk = Fieldname.GetChunk(lngOffset, ChunkSize)
End Function
'
'Private Sub Photo_Click()
'RaiseEvent Click
'End Sub

'The fallowing Sub  set the frame and resize it
'To the user size
Private Sub UserControl_Resize()
Photo.Move 20, 20, UserControl.Width - 20, UserControl.Height - 20
sHwnd = UserControl.hwnd
End Sub

Private Sub UserControl_InitProperties()
    m_ConnectionType = m_def_ConnectionType
End Sub

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
    m_ConnectionType = PropBag.ReadProperty("ConnectionType", m_def_ConnectionType)
    Photo.Stretch = PropBag.ReadProperty("Stretch", True)
'    Photo.BorderStyle = PropBag.ReadProperty("BackStyle", 0)
    Photo.BorderStyle = PropBag.ReadProperty("BorderStyle", 1)
    UserControl.BackColor = PropBag.ReadProperty("BackColor", &H8000000F)
    Set Picture = PropBag.ReadProperty("Picture", Nothing)
End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
    Call PropBag.WriteProperty("Stretch", Photo.Stretch, True)
    Call PropBag.WriteProperty("ConnectionType", m_ConnectionType, m_def_ConnectionType)
'    Call PropBag.WriteProperty("BackStyle", Photo.BorderStyle, 0)
    Call PropBag.WriteProperty("BorderStyle", Photo.BorderStyle, 1)
    Call PropBag.WriteProperty("BackColor", UserControl.BackColor, &H8000000F)
    Call PropBag.WriteProperty("Picture", Picture, Nothing)
End Sub

Public Property Get ConnectionType() As Connect
    ConnectionType = m_ConnectionType
End Property

Public Property Let ConnectionType(ByVal New_ConnectionType As Connect)
    m_ConnectionType = New_ConnectionType
    PropertyChanged "ConnectionType"
End Property

Public Property Get hwnd() As Long
    hwnd = UserControl.hwnd
End Property

Public Property Get Stretch() As Boolean
    Stretch = Photo.Stretch
End Property

Public Property Let Stretch(ByVal New_Stretch As Boolean)
    Photo.Stretch() = New_Stretch
    PropertyChanged "Stretch"
End Property
''
''WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
''MappingInfo=Photo,Photo,-1,BorderStyle
'Public Property Get BackStyle() As Integer
'    BackStyle = Photo.BorderStyle
'End Property
'
'Public Property Let BackStyle(ByVal New_BackStyle As Integer)
'    Photo.BorderStyle() = New_BackStyle
'    PropertyChanged "BackStyle"
'End Property
'
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=Photo,Photo,-1,BorderStyle
Public Property Get BorderStyle() As Integer
    BorderStyle = Photo.BorderStyle
End Property

Public Property Let BorderStyle(ByVal New_BorderStyle As Integer)
    Photo.BorderStyle() = New_BorderStyle
    PropertyChanged "BorderStyle"
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=UserControl,UserControl,-1,BackColor
Public Property Get BackColor() As OLE_COLOR
    BackColor = UserControl.BackColor
End Property

Public Property Let BackColor(ByVal New_BackColor As OLE_COLOR)
    UserControl.BackColor() = New_BackColor
    PropertyChanged "BackColor"
End Property

Private Sub Photo_Click()
    RaiseEvent Click
End Sub

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=Photo,Photo,-1,Picture
Public Property Get Picture() As Picture
    Set Picture = Photo.Picture
End Property

Public Property Set Picture(ByVal New_Picture As Picture)
    Set Photo.Picture = New_Picture
    PropertyChanged "Picture"
End Property

Its actually a User Control sir.

And I'm having this problem at the ActualSize thing (Line 127).

After saving info, with the pic, it does saves.

But when i try to access it (show info), i recieve an error.

"Could not find file 'C:\Documents\Pic\VbProject\Images\Database.mdb"

And if i open my DBase and look at the Pic field, its blank.

Edited 6 Years Ago by abelingaw: n/a

"Could not find file 'C:\Documents\Pic\VbProject\Images\Database.mdb"

And if i open my DBase and look at the Pic field, its blank.

This is your problem right here. The code you have was obviously copied from a site and pasted as is. The problem is that the database does not exist on your pc as in the code. I did however found the coding way too long. Try the code at the bottom. Remember to make sure that you change the data properties to your own database. It makes use of MS access.

'Add 2 command buttons and 2 picture boxes to your form

Option Explicit

Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Private Declare Function GetTempFileName Lib "kernel32" Alias "GetTempFileNameA" (ByVal lpszPath As String, ByVal lpPrefixString As String, ByVal wUnique As Long, ByVal lpTempFileName As String) As Long

'Purpose     :  Saves pictures in image boxes (or similiar) to a field in a recordset
'Inputs      :  oPictureControl                 A control containing an image
'               adoRS                           ADO recordset to add the image to
'               sFieldName                      The field name in adoRS, to add the image to
'Outputs     :  Returns True if succeeded in updating the recordset
'Notes       :  The field specified in sFieldName, must have a binary field type (ie. OLE Object in access)
'               Save the image at the currect cursor location in the recordset.
'Revisions   :

Public Function SavePictureToDB(oPictureControl As Object, adoRS As ADODB.Recordset, sFieldName As String) As Boolean
    Dim oPict As StdPicture
    Dim sDir As String, sTempFile As String
    Dim iFileNum As Integer
    Dim lFileLength As Long
    Dim abBytes() As Byte
    Dim iCtr As Integer
    
    On Error GoTo ErrHandler
    
    Set oPict = oPictureControl.Picture
    If oPict Is Nothing Then
        SavePictureToDB = False
        Exit Function
    End If

    'Save picture to temp file
    sTempFile = FileGetTempName
    SavePicture oPict, sTempFile
    
    'read file contents to byte array
    iFileNum = FreeFile
    Open sTempFile For Binary Access Read As #iFileNum
    lFileLength = LOF(iFileNum)
    ReDim abBytes(lFileLength)
    Get #iFileNum, , abBytes()
    'put byte array contents into db field
    adoRS.Fields(sFieldName).AppendChunk abBytes()
    Close #iFileNum
    
    'Don't return false if file can't be deleted
    On Error Resume Next
    Kill sTempFile
    SavePictureToDB = True
    Exit Function
    
ErrHandler:
    SavePictureToDB = False
    Debug.Print Err.Description
End Function


'Purpose     :  Loads a Picture, saved as binary data in a database, from a recordset into a picture control.
'Inputs      :  oPictureControl                 A control to load the image into
'               adoRS                           ADO recordset to add the image to
'               sFieldName                      The field name in adoRS, to add the image to
'Outputs     :  Returns True if succeeded in loading the image
'Notes       :  Loads the image at the currect cursor location in the recordset.


Public Function LoadPictureFromDB(oPictureControl As Object, adoRS As ADODB.Recordset, sFieldName As String) As Boolean
    Dim oPict As StdPicture
    Dim sDir As String
    Dim sTempFile As String
    Dim iFileNum As Integer
    Dim lFileLength As Long
    Dim abBytes() As Byte
    Dim iCtr As Integer
    
    On Error GoTo ErrHandler
    sTempFile = FileGetTempName
   
    iFileNum = FreeFile
    Open sTempFile For Binary As #iFileNum
    lFileLength = LenB(adoRS(sFieldName))
    
    abBytes = adoRS(sFieldName).GetChunk(lFileLength)
    Put #iFileNum, , abBytes()
    Close #iFileNum

    oPictureControl.Picture = LoadPicture(sTempFile)
    
    Kill sTempFile
    LoadPictureFromDB = True
    Exit Function
    
ErrHandler:
    LoadPictureFromDB = False
    Debug.Print Err.Description
End Function


'Purpose     :  The FileGetTempName function returns a name of a temporary file.
'Inputs      :  [sFilePrefix]               The prefix of the file name.
'Outputs     :  Returns the name of the next free temporary file name (and path).
'Notes       :  The filename is the concatenation of specified path and prefix strings,
'               a hexadecimal string formed from a specified integer, and the .TMP extension


Function FileGetTempName(Optional sFilePrefix As String = "TMP") As String
    Dim sTemp As String * 260, lngLen As Long
    Static ssTempPath As String
    
    If LenB(ssTempPath) = 0 Then
        'Get the temporary path
        lngLen = GetTempPath(260, sTemp)
        'strip the rest of the buffer
        ssTempPath = Left$(sTemp, lngLen)
        If Right$(ssTempPath, 1) <> "\" Then
            ssTempPath = ssTempPath & "\"
        End If
    End If
    
    'Get a temporary filename
    lngLen = GetTempFileName(ssTempPath, sFilePrefix, 0, sTemp)
    'Remove all the unnecessary chr$(0)'s
    FileGetTempName = Left$(sTemp, InStr(1, sTemp, Chr$(0)) - 1)
End Function


'SAMPLE USAGE
'NOTE : Add a PictureBox control to a form before running this code
Sub TestLoadPicture()
    Dim sConn As String
    Dim oConn As New ADODB.Connection
    Dim oRs As New ADODB.Recordset
    
    On Error GoTo ErrFailed
    sConn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=\\192.168.0.199\cserver\EmployeeCopies.MDB;Persist Security Info=False"
    
    oConn.Open sConn
    oRs.Open "SELECT * FROM Copies", oConn, adOpenKeyset, adLockOptimistic
    'If oRs.EOF = False Then
        LoadPictureFromDB Picture2, oRs, "EmpPhoto"
    'End If
    oRs.Close
    Exit Sub
ErrFailed:
    MsgBox "Error " & Err.Description
End Sub

'SAMPLE USAGE
'NOTE : Add a PictureBox control to a form before running this code
Sub TestSavePicture()
    Dim sConn As String
    Dim oConn As New ADODB.Connection
    Dim oRs As New ADODB.Recordset
    
    On Error GoTo ErrFailed
    sConn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=\\192.168.0.199\cserver\EmployeeCopies.MDB;Persist Security Info=False"
    
    oConn.Open sConn
    oRs.Open "SELECT * FROM Copies", oConn, adOpenKeyset, adLockOptimistic
    'If oRs.EOF = False Then
        oRs.AddNew
        SavePictureToDB Picture1, oRs, "EmpPhoto"
        oRs.Update
        MsgBox "saved"
    'End If
    oRs.Close
    Exit Sub
ErrFailed:
    MsgBox "Error " & Err.Description
End Sub

Private Sub Command1_Click()
Call TestLoadPicture
End Sub

Private Sub Command2_Click()
Call TestSavePicture
End Sub

Really need someone to fix my program ( i mean the whole thing ).

Have a look at the above code. It's simple and easy to understand and works 100% fine.

Again, remember to change the data connection properties and naming to your own database name and path.

Another thing to keep in mind when you design your database, make the field property of the field that will hold the picture as binary.:)

This article has been dead for over six months. Start a new discussion instead.