image_code.doc ( 88k ) Number of downloads: 46

hi i am new to vb6, i created the below code using vb6 as front end and Ms sql server as back end i want to store image file throught cdlg and then save it in sql data base img type by converting it into stream kindly suggest an easy way step by step in order to resolve this issue. i wll be very great full to u.... i need to submit this project this is only delayed for this.....hope you understand and reply soon.
waiting for your kind feedback.

Database name = warehouseporfile
Table name = Warehouseprofiledatabase
Field = uploadmapone
Type = image
Private Sub cmduploadsecuritymap_Click()
On Error GoTo a
cdlg.ShowOpen
'img1.Picture = LoadPicture(cdlg.FileName)
'FRMWHPROFILE.WHPROFILE.Fields("UploadMapone") = img1.Picture
'img1.Picture = Nothing
Label4.Caption = cdlg.FileName
Exit Sub
a:
End Sub

Private Sub cmdpreviewsecuritymap_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
On Error GoTo a
'img1.Picture = LoadPicture(FRMWHPROFILE.WHPROFILE.Fields("UploadMapone"))
'img1.Picture = LoadPicture(cdlg.FileName)
img1.Picture = LoadPicture(Label4.Caption)

Exit Sub
a:
End Sub

Private Sub Label4_Click()

End Sub

Private Sub img1_Click()

End Sub

For saving image

Dim imagepath1 As String
imagepath1 = FRMWHPROFILE.Label4.Caption
FRMWHPROFILE.WHPROFILE.Fields("uploadmapone") = imagepath1
Call SaveImage1

Private Function SaveImage1()
Dim mStream As New ADODB.Stream
With mStream
.Type = adTypeBinary
.Open
.LoadFromFile "c:\"
WHPROFILE("uploadmapone").Value = .Read
WHPROFILE.Update
End With
Set mStream = Nothing
End Function


For showing image

Call LoadImage1

Public Function LoadImage1()
Dim mStream As New ADODB.Stream
With mStream
.Type = adTypeBinary
.Open
FRMWHPROFILE.img1.DataField = "uploadmapone"
'Set DataField....
'Set FRMWHPROFILE.img1.DataSource = WHPROFILE
'Set DataSource
'Set FRMWHPROFILE.WHPROFILE.Fields("uploadmapone") = FRMWHPROFILE.img1.Picture
'Show image into a cell of
'Microsoft FlexGrid
End With
Set mStream = Nothing
End Function

Create a table call TblBlob. And a database called BLOB.
Creat two fields one will be blob and other one Long. PrefLogo as Blob or Ole Object and PrefLogoLength as Long.

Add three command button.

One listview and three CommondialogBox.

Option Explicit

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
Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Private Const MAX_PATH = 260

Private pobjConn As adodb.Connection
Public objRst As adodb.Recordset

Public pstrDBPath As String
Public pstrTableName As String


Private Const BLOCK_SIZE = 10000

Private Sub CmdLogoDB_Click()
DlgDB.Flags = cdlOFNFileMustExist Or cdlOFNHideReadOnly Or cdlOFNExplorer
DlgDB.CancelError = True
DlgDB.Filter = "Databases|*.mdb"

On Error Resume Next
DlgDB.ShowOpen
If Err.Number = cdlCancel Then
Exit Sub
ElseIf Err.Number <> 0 Then
MsgBox "Error " & Format$(Err.Number) & " selecting file." & vbCrLf & Err.Description
Exit Sub
End If
pstrDBPath = DlgDB.FileName
TxtDBPath.Text = pstrDBPath
End Sub

Public Sub Connection()
' Open the database connection.
Set pobjConn = New adodb.Connection
Set objRst = New adodb.Recordset
pobjConn.Provider = "Microsoft.Jet.OLEDB.4.0"
pobjConn.Properties("Data Source") = pstrDBPath
pobjConn.Open
End Sub

Private Sub CmdAddLogo_Click()
Dim objRst As adodb.Recordset
Dim file_num As String
Dim file_length As String
Dim bytes() As Byte
Dim num_blocks As Long
Dim left_over As Long
Dim block_num As Long
Dim booAnswer As Boolean
On Error GoTo Oops:

booAnswer = MsgBox("Adding a new logo to the database will erase any existing logos" & Chr(13) & "Do you want to proceed?", vbInformation + vbYesNo)
If booAnswer = vbNo Then
Exit Sub
End If

pstrTableName = Me.TxtTableName

Call Connection
'Delete any existing logos on the database
Set objRst = pobjConn.Execute("Delete * FROM " & pstrTableName & "")


DlgLogo.Flags = cdlOFNFileMustExist Or cdlOFNHideReadOnly Or cdlOFNExplorer
DlgLogo.CancelError = True
DlgLogo.Filter = "Graphics Files|*.bmp;*.ico;*.jpg;*.gif"

On Error Resume Next
DlgLogo.ShowOpen
If Err.Number = cdlCancel Then
Exit Sub
ElseIf Err.Number <> 0 Then
MsgBox "Error " & Format$(Err.Number) & " selecting file." & vbCrLf & Err.Description
Exit Sub
End If

On Error GoTo Oops:

'Open the picture file.
file_num = FreeFile

Open DlgLogo.FileName For Binary Access Read As #file_num
file_length = LOF(file_num)
If file_length > 0 Then

num_blocks = file_length / BLOCK_SIZE
left_over = file_length Mod BLOCK_SIZE

Set objRst = New adodb.Recordset
objRst.CursorType = adOpenKeyset
objRst.LockType = adLockOptimistic
objRst.Open "Select * FROM " & pstrTableName & "", pobjConn

objRst.AddNew
objRst!PrefLogoLength = file_length

ReDim bytes(BLOCK_SIZE)
For block_num = 1 To num_blocks
Get #file_num, , bytes()
objRst!PrefLogo.AppendChunk bytes()
Next block_num

If left_over > 0 Then
ReDim bytes(left_over)
Get #file_num, , bytes()
objRst!PrefLogo.AppendChunk bytes()
End If

objRst.Update
Close #file_num

End If

'Display added logo to make sure it works
Call CmdFetchLogo_Click

Oops:
Select Case Err.Number
Case 0

Case 3265
MsgBox "The " & pstrTableName & " table is missing one ore more fields." & vbCrLf & " Make sure the following fields exist on " & pstrTableName & " table." & vbCrLf & vbCrLf & " PrefLogo - An OLE Object Data Type field" & vbCrLf & " PrefLogoLength - A Number Data Type field set to Long Integer", vbInformation
Case -2147217843
MsgBox "Please select a DB to proceed", vbInformation
Case -2147217865
MsgBox "The Table you have entered does not exist on the DB" & vbCrLf & "If you have not done it yet, create a Table that MUST have the following fields:" & vbCrLf & vbCrLf & " PrefLogo - An OLE Object Data Type field" & vbCrLf & " PrefLogoLength - A Number Data Type field set to Long Integer", vbInformation
Case -2147467259
MsgBox "The Table " & pstrTableName & " is currently opened (locked)" & vbCrLf & "Please close it to proceed", vbInformation
Case Else
MsgBox "Error " & Format$(Err.Number) & vbCrLf & Err.Description
End Select

End Sub

' Return a temporary file name.
Private Function TemporaryFileName() As String
Dim temp_path As String
Dim temp_file As String
Dim length As Long

' Get the temporary file path.
temp_path = Space$(MAX_PATH)
length = GetTempPath(MAX_PATH, temp_path)
temp_path = Left$(temp_path, length)

' Get the file name.
temp_file = Space$(MAX_PATH)
GetTempFileName temp_path, "per", 0, temp_file
TemporaryFileName = Left$(temp_file, InStr(temp_file, Chr$(0)) - 1)
End Function

Private Sub CmdFetchLogo_Click()
Dim objRst As adodb.Recordset
Dim bytes() As Byte
Dim file_name As String
Dim file_num As Integer
Dim file_length As Long
Dim num_blocks As Long
Dim left_over As Long
Dim block_num As Long
Dim hgt As Single
On Error Resume Next

Screen.MousePointer = vbHourglass
DoEvents

' Get the record.
Set objRst = pobjConn.Execute("SELECT * FROM " & pstrTableName & "", , adCmdText)
If objRst.EOF Then Exit Sub

objRst.MoveFirst
' Get a temporary file name.
file_name = TemporaryFileName()

' Open the file.
file_num = FreeFile
Open file_name For Binary As #file_num

' Copy the data into the file.
file_length = objRst!PrefLogoLength
num_blocks = file_length / BLOCK_SIZE
left_over = file_length Mod BLOCK_SIZE

For block_num = 1 To num_blocks
bytes() = objRst!PrefLogo.GetChunk(BLOCK_SIZE)
Put #file_num, , bytes()
Next block_num

If left_over > 0 Then
bytes() = objRst!PrefLogo.GetChunk(left_over)
Put #file_num, , bytes()
End If

Close #file_num

' Display the picture file.
ListView.Picture = LoadPicture(file_name)

Kill file_name
Screen.MousePointer = vbDefault
End Sub

Private Sub CmdClose_Click()
End
End Sub