Howdy, Stranger!

It looks like you're new here. If you want to get involved, click one of these buttons!

Sign In with Facebook Sign In with Google Sign In with OpenID

Categories

We have migrated to a new platform! Please note that you will need to reset your password to log in (your credentials are still in-tact though). Please contact lee@programmersheaven.com if you have questions.
Welcome to the new platform of Programmer's Heaven! We apologize for the inconvenience caused, if you visited us from a broken link of the previous version. The main reason to move to a new platform is to provide more effective and collaborative experience to you all. Please feel free to experience the new platform and use its exciting features. Contact us for any issue that you need to get clarified. We are more than happy to help you.

Crop an image and save to SQL server

1966ponyguy1966ponyguy Posts: 1Member
I am new to the group, Hi everyone. I have been programming now for about 1 1/2 years. I am working on a project that requires me to be able to open an image (jpg) resize as needed, then crop a selection and save that cropped image to a sql file. I have the resize working and the save working but I cannot get only the cropped selection to save. HELP PLEASE. Thanks in advance:

Option Explicit

Dim sngScale As Single
Dim dblHeight As Double
Dim bDragImage As Boolean
Dim bMouseButton As Integer
Dim NewImage_Width As Double
Dim NewImage_Height As Double
Dim DragX As Double
Dim DragY As Double
Dim iEmpNumber As Long

' Used to move box on image
Dim iXPosition As Integer
Dim iYPosition As Integer
Dim bCropped As Boolean

Dim rs As ADODB.Recordset ' recordset for saving stream to database
Dim mStream As ADODB.Stream

Public Function Display(Emp As Long)

With Me
.ZOrder 0
.Show
End With

LoadImage
iEmpNumber = Emp

End Function

Private Sub cmdCrop_Click()

With frmInfo.picEmp
.ScaleMode = vbPixels
.PaintPicture pictZoom.Image, 0, 0, shapeCrop.Width, shapeCrop.Height, _
shapeCrop.Left / 16, shapeCrop.TOp / 16, shapeCrop.Width, _
shapeCrop.Height, vbSrcCopy

End With

cmdSave

Unload Me

End Sub

Private Sub cmdSave()

Dim itest As Integer

Set rs = New ADODB.Recordset
rs.Open "Select * FROM Employees WHERE Employee_Number = " & iEmpNumber & " ", cnSQLADO, adOpenKeyset, adLockOptimistic
itest = rs.RecordCount
Set mStream = New ADODB.Stream
mStream.Type = adTypeBinary
mStream.Open
mStream.LoadFromFile ("C:IDPics" & iEmpNumber & ".jpg")
rs.Fields("IDPic").Value = mStream.Read
rs.Update
rs.Close

End Sub


Private Sub HScroll_Change()

If bMouseButton = 0 Then MovePicture

End Sub

Private Sub HScroll_Scroll()

MovePicture

End Sub

Private Sub pictzoom_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)

Select Case Button
Case 1

Case 2
DragX = x + HScroll.Value
DragY = y + VScroll.Value
End Select

bMouseButton = Button

End Sub

Private Sub pictzoom_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)

Dim H As Integer
Dim V As Integer

Select Case bMouseButton
Case 1
With shapeCrop
shapeCrop.Move x, y

If .Left <= 0 Then
.Move 1
End If
If .TOp <= 0 Then
.Move .Left, 1
End If
If .Left + .Width >= pictZoom.ScaleWidth Then
.Move pictZoom.ScaleWidth - (.Width - 1)
End If
If .TOp + .Height >= pictZoom.ScaleHeight Then
.Move .Left, pictZoom.ScaleHeight - (.Height)
End If
End With

With frmInfo.picEmp
.PaintPicture pictZoom.Image, 0, 0, shapeCrop.Width, shapeCrop.Height, _
shapeCrop.Left / 16, shapeCrop.TOp / 16, shapeCrop.Width, _
shapeCrop.Height, vbSrcCopy

.PaintPicture pictZoom.Image, 0, 0, shapeCrop.Width, shapeCrop.Height, shapeCrop.Left, _
shapeCrop.TOp, shapeCrop.Width, shapeCrop.Height, vbSrcCopy
End With

Case 2
'If bDragImage = False Then Exit Sub
H = Int(DragX - x)
V = Int(DragY - y)
If H < 0 Then H = 0 Else If H > HScroll.Max Then H = HScroll.Max
If V < 0 Then V = 0 Else If V > VScroll.Max Then V = VScroll.Max
HScroll.Value = H
VScroll.Value = V
MovePicture

End Select

End Sub

Private Sub pictzoom_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)

bDragImage = False
bMouseButton = 0

End Sub

Private Sub Slider1_Change()

PictureUpdate

End Sub

Private Sub Slider1_Click()
PictureUpdate
End Sub

Private Sub Slider1_Scroll()

PictureUpdate

End Sub

Private Sub MovePicture()

Dim iScale As Double

iScale = (Slider1.Value / 100)
pictZoom.PaintPicture pictOriginal, 0, 0, pictZoom.Width, pictZoom.Height, (HScroll.Value / iScale), VScroll.Value / iScale, pictZoom.Width / iScale, pictZoom.Height / iScale, vbSrcCopy

End Sub

Private Sub ScrollAdjust()

HScroll.Enabled = True
HScroll.LargeChange = pictZoom.Width / 10
HScroll.Value = 0

VScroll.Enabled = True
VScroll.LargeChange = pictZoom.Height / 10

End Sub

Private Sub VScroll_Change()

If bDragImage = False Then MovePicture
Debug.Print VScroll.Value

End Sub

Private Sub VScroll_Scroll()

MovePicture

End Sub

Private Sub PictureUpdate()

Dim WWW As Double
Dim HHH As Double

WWW = NewImage_Width * (Slider1.Value / 100)
If WWW > (VScroll.Left - pictZoom.Left) Then pictZoom.Width = (VScroll.Left - pictZoom.Left) Else pictZoom.Width = WWW

HHH = NewImage_Height * (Slider1.Value / 100)
If HHH > (HScroll.TOp - pictZoom.TOp) Then pictZoom.Height = (HScroll.TOp - pictZoom.TOp) Else pictZoom.Height = HHH

HScroll.Max = WWW - pictZoom.Width
VScroll.Max = HHH - pictZoom.Height

ScrollAdjust

pictZoom.PaintPicture pictOriginal, 0, 0, WWW, HHH, 0, 0, NewImage_Width, NewImage_Height, vbSrcCopy

With shapeCrop
If (.Left + .Width) >= pictZoom.Width And pictZoom.ScaleWidth - (.Width - 1) >= 0 Then
.Move pictZoom.ScaleWidth - (.Width - 1)
End If
If (.TOp + .Height) >= pictZoom.ScaleHeight And (pictZoom.ScaleY(.TOp, 1, 3) - 1) > 1 Then
.Move .Left, pictZoom.ScaleHeight - (.Height - 1)
End If
If .TOp < 1 Then
.Move .Left, 1
End If
If .Left < 1 Then
.Move 1
End If
End With

End Sub

Private Function LoadImage()

Dim iMin As Integer

With CDialog
.Filter = "JPEG (*.jpg)|*.jpg|Graphic Interchange Format (*.gif)|*.gif|Windows Bitmap (*.bmp)|*.bmp"
.ShowOpen
If Len(Trim(.Filename)) > 0 Then
pictOriginal.Picture = LoadPicture(.Filename)
Me.Caption = Me.Caption & " " & .Filename
Else
Unload Me
Exit Function
End If
End With

pictZoom.Visible = True
pictZoom.Picture = pictOriginal.Picture
NewImage_Width = pictZoom.Width
NewImage_Height = pictZoom.Height
Slider1.Value = 100
Slider1.Max = 500

If NewImage_Width * (Slider1.Max / 100) > 32000 Then Slider1.Max = (32000 / NewImage_Width) * 100
If NewImage_Height * (Slider1.Max / 100) > 32000 Then Slider1.Max = (32000 / NewImage_Height) * 100

iMin = (shapeCrop.Height / Round((pictOriginal.Height)) * 100) + 1

If iMin < (shapeCrop.Width / Round((pictOriginal.Width)) * 100) + 1 Then
iMin = (shapeCrop.Width / Round((pictOriginal.Width)) * 100) + 1
End If

If iMin > Slider1.Max Then
Slider1.Max = iMin * 2
Else
Slider1.Max = iMin * 20
End If

Slider1.Min = iMin

'pictZoom.Cls
PictureUpdate
ScrollAdjust
cmdCrop.Enabled = True

End Function

Sign In or Register to comment.