Start a new project
Add new Modul
Add new Class
in Project Add a Reference File
Microsoft ActiveX Data Objects 2.0 Library
Add Components - Microsoft Common Dialog Control 6.0
Create New Table this type
in Project folder Store two file 1: PICTEMP 2: 2.JPG
Module :
Option Explicit
Private Const mcstrMod$ = "Module1"
Public ErrNum As Long, ErrMsg As String
Public conn As New ADODB.Connection
Public Sub Main()
Set conn = New ADODB.Connection
conn.CursorLocation = adUseServer
conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;User ID=Admin;Data Source=" & App.Path & "\Database.mdb;Mode=Share Deny None;Extended Properties="""";Jet OLEDB:System database="""";Jet OLEDB:Registry Path="""";Jet OLEDB:Database Password="""";Jet OLEDB:Engine Type=4;Jet OLEDB:Database Locking Mode=0;Jet OLEDB:Global Partial Bulk Ops=2;Jet OLEDB:Global Bulk Transactions=1;Jet OLEDB:New Database Password="""";Jet OLEDB:Create System Database=False;Jet OLEDB:Encrypt Database=False;Jet OLEDB:Don't Copy Locale on Compact=False;Jet OLEDB:Compact Without Replica Repair=False;Jet OLEDB:SFP=False"
Form1.Show
End Sub
Public Function ErrHandler(ByVal ErrorNumber As Long, ByVal ErrorMessage As String, ByVal ModuleName As String, ByVal FunctionName As String)
'Err.Raise ErrorNumber, app.EXEName & "." & ModuleName & "." & FunctionName, ErrorMessage
'optionally you can display an error msgbox
MsgBox "Error Number:" & ErrorNumber & vbCrLf & _
"Error Message:" & ErrorMessage & vbCrLf & _
"Module:" & ModuleName & vbCrLf & _
"Function:" & FunctionName, vbCritical
End Function
Function ErrorMsg(ErrNum As Long, ErrDesc As String, _
strFunction As String, strModule As String)
On Error Resume Next
Dim anErrorMessage As String
anErrorMessage = "Error Number: " & ErrNum & "." & vbCrLf & _
"Error Description: " & ErrDesc & vbCrLf & _
"Module Name: " & strModule & vbCrLf & _
"Sub/Function: " & strFunction & vbCrLf
MsgBox anErrorMessage, vbCritical
End Function
Class :
Option Explicit
'local variable(s) to hold property value(s)
Private mvarID As Long 'local copy
Private mvarpicImage As String 'local copy
Private mvarpdate As Date 'local copy
Dim Chunk() As Byte
Dim lngLengh As Long
Dim intChunks As Integer
Dim intFragment As Integer
Const ChunkSize = 1000 '16384
Const lngDataFile = 1
Public Property Let pdate(ByVal vData As Date)
'used when assigning a value to the property, on the left side of an assignment.
'Syntax: X.pdate = 5
mvarpdate = vData
End Property
Public Property Get pdate() As Date
'used when retrieving value of a property, on the right side of an assignment.
'Syntax: Debug.Print X.pdate
pdate = mvarpdate
End Property
Public Property Let picImage(ByVal vData As String)
'used when assigning a value to the property, on the left side of an assignment.
'Syntax: X.picImage = 5
mvarpicImage = vData
End Property
Public Property Get picImage() As String
'used when retrieving value of a property, on the right side of an assignment.
'Syntax: Debug.Print X.picImage
picImage = mvarpicImage
End Property
Public Property Let ID(ByVal vData As Long)
'used when assigning a value to the property, on the left side of an assignment.
'Syntax: X.ID = 5
mvarID = vData
End Property
Public Property Get ID() As Long
'used when retrieving value of a property, on the right side of an assignment.
'Syntax: Debug.Print X.ID
ID = mvarID
End Property
Public Function Save(Optional ByVal bolStartTran As Boolean) As Boolean
'
Dim rsImage As ADODB.Recordset
Dim strSQL As String
Dim Count As Long, i As Long, bolInTran As Boolean
On Error GoTo Err_Save
If bolStartTran Then
conn.BeginTrans
bolInTran = True
End If
Set rsImage = New ADODB.Recordset
strSQL = "Select * FROM [Table1] a WHERE a.ID =" & mvarID & ""
rsImage.Open strSQL, conn, adOpenKeyset, adLockOptimistic
If (Dir(Trim(mvarpicImage)) = "") Then GoTo Done_Save 'Exit Sub
'Open as Binary
Open Trim(mvarpicImage) For Binary Access Read As lngDataFile
lngLengh = LOF(lngDataFile) ' Length of data in file
If lngLengh = 0 Then Close lngDataFile: GoTo Done_Save 'Exit Sub
intChunks = lngLengh \ ChunkSize
intFragment = lngLengh Mod ChunkSize
If Not rsImage.EOF Then
SaveRecord:
rsImage("PDate") = mvarpdate
rsImage("picImage1") = mvarpicImage
ReDim Chunk(intFragment)
'Read data from a file into a variable
Get lngDataFile, , Chunk()
'Appends data to a large text or binary data Field or Parameter object.
rsImage!picImage.AppendChunk Chunk() 'picImage
ReDim Chunk(ChunkSize)
For i = 1 To intChunks
Get lngDataFile, , Chunk()
rsImage!picImage.AppendChunk Chunk()
Next i
'Update
rsImage.Update
'Close File
Close lngDataFile
'Show Pic in PictureBox
'Call ShowPic
Else
'Add New Record in DataBase
rsImage.AddNew
GoTo SaveRecord
End If
rsImage.Close
Skip_Save:
If bolInTran Then
conn.CommitTrans
bolInTran = False
End If
Save = True
Done_Save:
Exit Function
Err_Save:
If bolStartTran Then GoSub Rollback_Save
ErrNum = Err.Number
ErrMsg = Err.Description
Call ErrHandler(ErrNum, ErrMsg, "Class1", "Save")
GoTo Done_Save
Rollback_Save:
If bolInTran Then conn.RollbackTrans
Return
End Function
Public Function LoadData(ID As Long) As Boolean
'
On Error GoTo Err_Load
Dim rsImage As New ADODB.Recordset
mvarID = ID
Dim strSQL As String
strSQL = "Select * FROM [Table1] a WHERE a.ID =" & mvarID & ""
rsImage.Open strSQL, conn, adOpenStatic, adLockReadOnly
'If Not rsImage.EOF Then
If rsImage.RecordCount > 0 Then
Open "pictemp" For Binary Access Write As lngDataFile
lngLengh = rsImage!picImage.ActualSize
intChunks = lngLengh \ ChunkSize
intFragment = lngLengh Mod ChunkSize
ReDim Chunk(intFragment)
Chunk() = rsImage!picImage.GetChunk(intFragment)
Put lngDataFile, , Chunk()
Dim i As Integer
For i = 1 To intChunks
ReDim Buffer(ChunkSize)
Chunk() = rsImage!picImage.GetChunk(ChunkSize)
Put lngDataFile, , Chunk()
Next i
Close lngDataFile
mvarpicImage = IIf(IsNull(rsImage("picImage1")), "", rsImage("picImage1"))
mvarpdate = IIf(IsNull(rsImage("PDate")), Now(), rsImage("PDate"))
Else
rsImage.Close
LoadData = False
Exit Function
End If
rsImage.Close
LoadData = True
Exit Function
Err_Load:
ErrNum = Err.Number
ErrMsg = Err.Description
LoadData = False
Call ErrHandler(ErrNum, ErrMsg, "Class1", "LoadData")
End Function
Form :
Option Explicit
Dim cls1 As New Project1.Class1
Private Sub Command1_Click()
'Select JPG OR Bitmap File to Store in DataBase
On Error Resume Next
With CommonDialog1
.Filter = "JPG Files|*.JPG|Bitmaps|*.BMP|GIF Files|*.GIF"
.ShowOpen
Text1.Text = .FileName
End With
Image1.Picture = LoadPicture(Text1.Text)
End Sub
Private Sub Command2_Click()
cls1.pdate = Now()
cls1.picImage = Text1.Text
If cls1.Save = True Then
MsgBox "pros done"
End If
End Sub
Dim i As Long
i = CLng(txtID.Text)
If cls1.LoadData(i) = True Then
Text1.Text = cls1.picImage
Image1.Picture = LoadPicture("pictemp")
End If
End Sub
Private Sub Command4_Click()
Dim lNewWidth As Long, lNewHeight As Long, iZoomFactor As Integer
iZoomFactor = 2
If iZoomFactor = 0 Then
lNewWidth = Image1.Picture.Width
lNewHeight = Image1.Picture.Height
ElseIf iZoomFactor > 0 Then
lNewWidth = Image1.Picture.Width * iZoomFactor
lNewHeight = Image1.Picture.Height * iZoomFactor
Else
lNewWidth = Image1.Picture.Width / -iZoomFactor
lNewHeight = Image1.Picture.Height / -iZoomFactor
End If
Picture1.Cls
Picture1.PaintPicture Image1.Picture, 0, 0, lNewWidth, lNewHeight
End Sub
No comments:
Post a Comment