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 PropertyIts 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.
Really need someone to fix my program ( i mean the whole thing ).
"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 SubReally 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.:)
We're a friendly, industry-focused community of developers, IT pros, digital marketers, and technology enthusiasts meeting, networking, learning, and sharing knowledge.