Visual Basic 6 Crystal Reports Pic Code

Option Explicit

Const MAX_PATH = 255

Private Declare Function GetTempPath Lib "kernel32" _
Alias "GetTempPathA" (ByVal nBufferLength As Long, _
ByVal lpBuffer As String) As Long





Public Function SavePictureToDB(PictControl As Object, _
RS As Object, FieldName As String) As Boolean

'PURPOSE: SAVES PICTURE IN IMAGEBOX, PICTUREBOX, OR SIMILAR
'CONTROL TO RECORDSET RS IN FIELD NAME FIELDNAME

'FIELD TYPE MUST BE BINARY (OLE OBJECT IN ACCESS)


'SAMPLE USAGE
'Dim sConn As String
'Dim oConn As New ADODB.Connection
'Dim oRs As New ADODB.Recordset
'
'
'sConn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=C:\MyDb.MDB;Persist Security Info=False"
'
'oConn.Open sConn
'oRs.Open "SELECT * FROM MYTABLE", oConn, adOpenKeyset, _
adLockOptimistic
'oRs.AddNew

'SavePictureToDB Picture1, oRs, "MYFIELD"
'oRs.Update
'oRs.Close

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 ErrorHandler
If Not TypeOf RS Is ADODB.Recordset Then Exit Function
Set oPict = PictControl.Picture
If oPict Is Nothing Then Exit Function

'Save picture to temp file
sDir = GetTempDir
If sDir = "" Then sDir = "C:\"
sTempFile = sDir & "0X2341KLZX.dat"
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
RS.Fields(FieldName).AppendChunk abBytes()
Close #iFileNum

'Don't return false if file can't be deleted
On Error Resume Next
Kill sTempFile
SavePictureToDB = True
ErrorHandler:
End Function

Public Function LoadPictureFromDB(PictControl As Object, _
RS As Object, FieldName As String) As Boolean

'PURPOSE: LOADS PICTURE, SAVED AS BINARY DATA IN RECORDSET RS,
'FIELD FieldName TO PICTUREBOX, IMAGEBOX (OR CONTROL
'WITH SIMILAR INTERFACE)


'SAMPLE USAGE
'Dim sConn As String
'Dim oConn As New ADODB.Connection
'Dim oRs As New ADODB.Recordset
'
'
'sConn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=C:\MyDb.MDB;Persist Security Info=False"
'
'oConn.Open sConn
'oRs.Open "SELECT * FROM MyTable", oConn, adOpenKeyset,
' adLockOptimistic
'LoadPictureFromDB Picture1, oRs, "MyFieldName"
'oRs.Close

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 ErrorHandler
If Not TypeOf RS Is ADODB.Recordset Then Exit Function
sDir = GetTempDir
If sDir = "" Then sDir = "C:\"
sTempFile = sDir & "0X2341KLZX.dat"

If Len(Dir$(sTempFile)) > 0 Then
Kill sTempFile
End If

iFileNum = FreeFile
Open sTempFile For Binary As #iFileNum
lFileLength = LenB(RS(FieldName))


abBytes = RS(FieldName).GetChunk(lFileLength)
Put #iFileNum, , abBytes()



Close #iFileNum

PictControl.Picture = LoadPicture(sTempFile)

Kill sTempFile
LoadPictureFromDB = True

ErrorHandler:
End Function

Private Function GetTempDir() As String
Dim sRet As String, lngLen As Long

'create buffer
sRet = String(MAX_PATH, 0)

lngLen = GetTempPath(MAX_PATH, sRet)
If lngLen = 0 Then Exit Function
GetTempDir = Left$(sRet, lngLen)
End Function