I have userform1 for viewing jpg's from a list of urls. I find the url the user selected from the list, download the jpg to a temp file and then load it in to a image control on userform1. I am creating a magnifier with the left mouse button and a magnification selector with the right mouse button. When the right mouse button is clicked it brings up userform2 where the user selects the magnification they want and it is stored in a textbox on userform1. The magnification selector works fine. There is a second image control on the userform1 that is only visible when the left mouse button is depressed and is suppose to show the magnified image. To get the magnified image I retrieve the downloaded image from the temp file, cropping it and then resave it as a new temp file. I then load the resaved-cropped image into the second image control. The second image control is then centered on the mouse corrodents and made visible. Everything works except the cropping of the image. I receive a error saying that the cropping contains negative number and can't be performed. I am lost. The only thing I can figure is that during the cropping the image size is decreasing so the cropping is larger than the image. I structured the code so that the cropping is bottom then top and right then left. Even if the image size decreases by doing it in this order it should never be negative.
Private Sub UpdateMagnifiedView(ByVal X As Single, ByVal Y As Single)
Debug.Print "Control Corrodents X=" & X & " Y=" & Y
Debug.Print ""
Debug.Print "Image Size W=" & Image1.Picture.Width & " H=" & Image1.Picture.Height
Debug.Print ""
Dim XCrop As Long
Dim YCrop As Long
Dim CLeft As Long
Dim CTop As Long
Dim CRight As Long
Dim CBottom As Long
XCrop = Image1.Picture.Width / Image1.Width * X
YCrop = Image1.Picture.Height / Image1.Height * Y
CLeft = XCrop - (XCrop * (TextBox1.Value / 100))
CRight = XCrop + (XCrop * (TextBox1.Value / 100))
CTop = YCrop - (YCrop * (TextBox1.Value / 100))
CBottom = YCrop + (YCrop * (TextBox1.Value / 100))
Debug.Print "Pixel Corrodents XCrop=" & XCrop & " YCrop=" & YCrop
Debug.Print ""
Debug.Print "Crop from Left = " & CLeft
Debug.Print "Crop from Right = " & CRight
Debug.Print "Crop from Top = " & CTop
Debug.Print "Crop from Bottom = " & CBottom
Crop_Image TempFilePath, TempPicturePath, CLeft, CTop, CRight, CBottom
Image2.Picture = LoadPicture("")
Image2.Picture = LoadPicture(TempPicturePath)
End Sub
Sub Crop_Image(StartImage As String, FinishImage As String, CLeft As Long, CTop As Long, CRight As Long, CBottom As Long)
Dim ImagetoChop As Object
Dim Chopper As Object
Dim SaveCropImage As String
Set ImagetoChop = CreateObject("WIA.ImageFile")
Set Chopper = CreateObject("WIA.ImageProcess")
ImagetoChop.LoadFile StartImage
Chopper.Filters.Add Chopper.FilterInfos("Crop").FilterID
Chopper.Filters(1).Properties("Bottom") = CBottom
Chopper.Filters(1).Properties("Right") = CRight
Chopper.Filters(1).Properties("Left") = CLeft
Chopper.Filters(1).Properties("Top") = CTop
Set ImagetoChop = Chopper.Apply(ImagetoChop)
SaveCropImage = FinishImage
If Len(Dir(SaveCropImage)) > 0 Then Kill SaveCropImage
ImagetoChop.SaveFile SaveCropImage
End Sub
First let me give credit to Daniel Pineault on DevHut. His article "How to Crop an Image Using WIA in VBA" gave me everything I needed to work out this code (https://www.devhut.net/how-to-crop-an-image-using-wia-in-vba/). Here is the completed code for my userform to: Display images in a image control from a URL. Cycle between images with a next and previous buttons, Select a magnification level, Magnify the image based on selection and the x/y coordinates of the mouse click:
Option Explicit
Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" _
(ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, _
ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
Private currentImageIndex As Long
Private imageUrls As Variant
Private IsMouseDown As Boolean
Private TempFilePath As String
Private TempPicturePath As String
Private Sub btnClose_Click()
On Error GoTo ErrorHandler
' Check if temporary files exist and delete them
If Dir(TempFilePath) <> "" Then
Kill TempFilePath
End If
If Dir(TempPicturePath) <> "" Then
Kill TempPicturePath
End If
Unload Me
Exit Sub ' Exit sub if no errors occur
ErrorHandler:
' Handle errors here
MsgBox "An error occurred: " & Err.Description, vbExclamation
Resume Next ' Resume execution after error
End Sub
Private Sub UserForm_Initialize()
' Declare variables
Dim Ws1 As Worksheet
Dim Ws2 As Worksheet
Dim Ws3 As Worksheet
Dim Ws4 As Worksheet
Dim Ws5 As Worksheet
Dim lastRow As Long
Dim i As Long
Dim RowJob As Range
Dim JobUUID As String
' Set visibility of form elements
btnNext.Visible = True
btnPrevious.Visible = True
lbClose.Visible = False
' Define temporary file paths
On Error Resume Next
TempFilePath = Environ$("temp") & "\" & "Temp_image.jpg"
TempPicturePath = Environ$("temp") & "\" & "TempZoomImage.jpg"
On Error GoTo 0 ' Reset error handling
' Set references to worksheets
On Error GoTo ErrorHandler
Set Ws1 = ThisWorkbook.Sheets("Attachments")
Set Ws2 = ThisWorkbook.Sheets("AllbyStaff")
Set Ws3 = ThisWorkbook.Sheets("Santiago")
Set Ws4 = ThisWorkbook.Sheets("Jim")
Set Ws5 = ThisWorkbook.Sheets("Data")
On Error GoTo 0 ' Reset error handling
' Find row containing CtrName in different sheets
On Error GoTo ErrorHandler
If Not (Ws2.Columns("G").Find(CtrName, LookIn:=xlValues, LookAt:=xlWhole) Is Nothing) Then
Set RowJob = Ws2.Columns("G").Find(CtrName, LookIn:=xlValues, LookAt:=xlWhole)
ElseIf Not (Ws3.Columns("G").Find(CtrName, LookIn:=xlValues, LookAt:=xlWhole) Is Nothing) Then
Set RowJob = Ws3.Columns("G").Find(CtrName, LookIn:=xlValues, LookAt:=xlWhole)
ElseIf Not (Ws4.Columns("G").Find(CtrName, LookIn:=xlValues, LookAt:=xlWhole) Is Nothing) Then
Set RowJob = Ws4.Columns("G").Find(CtrName, LookIn:=xlValues, LookAt:=xlWhole)
End If
On Error GoTo 0 ' Reset error handling
' Get JobUUID from Ws2 based on RowJob
On Error GoTo ErrorHandler
JobUUID = Ws2.Cells(RowJob.Row, 4).Value
On Error GoTo 0 ' Reset error handling
' Find the last row in Ws1
On Error GoTo ErrorHandler
lastRow = Ws1.Cells(Ws1.Rows.Count, "A").End(xlUp).Row
On Error GoTo 0 ' Reset error handling
' Initialize imageUrls array
ReDim imageUrls(1 To 1)
' Retrieve image URLs for JobUUID
On Error Resume Next
For i = 1 To lastRow
If Ws1.Cells(i, "H").Value = JobUUID Then
imageUrls(UBound(imageUrls)) = "https://api.servicem8.com/api_1.0/Attachment/" & Ws1.Cells(i, "A").Value & ".file"
ReDim Preserve imageUrls(1 To UBound(imageUrls) + 1)
End If
Next i
On Error GoTo 0 ' Reset error handling
' Trim the imageUrls array
If UBound(imageUrls) > 1 Then
ReDim Preserve imageUrls(1 To UBound(imageUrls) - 1)
End If
' Set current image index
currentImageIndex = 1
' Set form dimensions and positions of buttons
With Me
.Width = Application.Width
.Height = Application.Height
.Left = Application.Left
.Top = Application.Top
End With
' Position Next button
With btnNext
.Width = 50
.Height = 50
.Left = Me.Width - 100
.Top = (Me.Height / 2) - (.Height / 2)
End With
' Position Previous button
With btnPrevious
.Width = 50
.Height = 50
.Left = 50
.Top = (Me.Height / 2) - (.Height / 2)
End With
' Position Close button
With btnClose
.Width = 100
.Height = 50
.Left = Me.Width - 150
.Top = Me.Height - 100
End With
' Set value of TextBox1
TextBox1.Value = Ws5.Cells(2, 1).Value
' Display current image
ShowCurrentImage
Exit Sub
ErrorHandler:
MsgBox "An error occurred: " & Err.Description, vbExclamation
End Sub
Private Sub ShowCurrentImage()
' Declare variables
Dim imageUrl As String
' Check if the currentImageIndex is within the bounds of the imageUrls array
If UBound(imageUrls) >= currentImageIndex Then
On Error Resume Next
' Attempt to assign the URL from the imageUrls array to the imageUrl variable
imageUrl = imageUrls(currentImageIndex)
' Reset error handling to default
On Error GoTo 0
End If
' Call subroutine to load image from URL
LoadImageFromURL imageUrl, TempFilePath
' Call subroutine to display image on user form
ShowImageOnUserForm TempFilePath
' Resize the image control on the user form
ResizeImageControl
End Sub
Private Sub LoadImageFromURL(ByVal url As String, ByVal TempFilePath As String)
' Enable error handling
On Error Resume Next
' Download image from URL to temporary file path
URLDownloadToFile 0, url, TempFilePath, 0, 0
' Reset error handling to default
On Error GoTo 0
End Sub
Private Sub ShowImageOnUserForm(ByVal TempFilePath As String)
' Check if the temporary file path contains a file
If Len(Dir(TempFilePath)) > 0 Then
' Load picture from the temporary file path and display it on the user form
Me.Image1.Picture = LoadPicture(TempFilePath)
Else
' If the file is not found, display an error message
MsgBox "Error loading image from URL.", vbExclamation
End If
End Sub
Private Sub ResizeImageControl()
On Error GoTo ErrorHandler ' Enable error handling
Dim originalWidth As Single
Dim originalHeight As Single
Dim aspectRatio As Single
' Get the original width and height of the image
originalWidth = Image1.Picture.Width
originalHeight = Image1.Picture.Height
' Calculate the aspect ratio
aspectRatio = originalWidth / originalHeight
' Resize the image control based on aspect ratio
If originalWidth > originalHeight Then
Image1.Width = Application.UsableWidth * 0.8
Image1.Height = Image1.Width / aspectRatio
Else
Image1.Height = Application.UsableHeight
Image1.Width = Image1.Height * aspectRatio
End If
' Set the picture size mode to zoom
Image1.PictureSizeMode = fmPictureSizeModeZoom
' Center the image control vertically and horizontally on the form
Image1.Top = (Me.Height - Image1.Height) / 2
Image1.Left = (Me.Width - Image1.Width) / 2
Exit Sub ' Exit the subroutine if no error occurs
ErrorHandler: ' Handle errors
MsgBox "An error occurred: " & Err.Description, vbExclamation
End Sub
Private Sub btnNext_Click()
On Error GoTo ErrorHandler ' Enable error handling
' Increment the current image index
currentImageIndex = currentImageIndex + 1
' If it exceeds the upper bound of image URLs, reset it to 1
If currentImageIndex > UBound(imageUrls) Then
currentImageIndex = 1
End If
' Show the current image
ShowCurrentImage
' Refresh the visibility of the image control
Image1.Visible = False
Image1.Visible = True
Exit Sub ' Exit the subroutine if no error occurs
ErrorHandler: ' Handle errors
MsgBox "An error occurred: " & Err.Description, vbExclamation
End Sub
Private Sub btnPrevious_Click()
On Error GoTo ErrorHandler ' Enable error handling
' Decrement the current image index
currentImageIndex = currentImageIndex - 1
' If it becomes less than 1, set it to the upper bound of image URLs
If currentImageIndex < 1 Then
currentImageIndex = UBound(imageUrls)
End If
' Show the current image
ShowCurrentImage
' Refresh the visibility of the image control
Image1.Visible = False
Image1.Visible = True
Exit Sub ' Exit the subroutine if no error occurs
ErrorHandler: ' Handle errors
MsgBox "An error occurred: " & Err.Description, vbExclamation
End Sub
Private Sub Image1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
On Error GoTo ErrorHandler
' Button = 1 corresponds to left mouse button
' If left mouse button is clicked
If Button = 1 Then
' Set IsMouseDown flag to True to indicate mouse down event
IsMouseDown = True
' Update the magnified view based on the current mouse coordinates
UpdateMagnifiedView X, Y
' Make Image2 visible to display the magnified view
Image2.Visible = True
' Button = 2 corresponds to right mouse button
ElseIf Button = 2 Then
' If right mouse button is clicked, show MagnifierSeL (assuming MagnifierSeL is a user-defined form or object)
MagnifierSeL.Show
End If
Exit Sub
ErrorHandler:
' Handle any errors that may occur during mouse down event
MsgBox "An error occurred: " & Err.Description
End Sub
Private Sub Image1_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
On Error GoTo ErrorHandler
' Button = 1 corresponds to left mouse button
' If left mouse button is released
If Button = 1 Then
' Set IsMouseDown flag to False to indicate mouse up event
IsMouseDown = False
' Clear the picture in Image2 to remove the magnified view
Image2.Picture = LoadPicture("")
' Make Image2 invisible
Image2.Visible = False
End If
Exit Sub
ErrorHandler:
' Handle any errors that may occur during mouse up event
MsgBox "An error occurred: " & Err.Description
End Sub
Private Sub UpdateMagnifiedView(ByVal X As Single, ByVal Y As Single)
On Error GoTo ErrorHandler
Dim XCrop As Long
Dim YCrop As Long
Dim CLeft As Long
Dim CTop As Long
Dim CRight As Long
Dim CBottom As Long
Dim ScaleFactor As Long
' Determine the scale factor based on TextBox1 value
Select Case TextBox1.Value
Case 2
ScaleFactor = 500
Case 4
ScaleFactor = 400
Case 6
ScaleFactor = 300
Case 8
ScaleFactor = 200
Case 10
ScaleFactor = 100
Case Else
' Handle unexpected values in TextBox1
MsgBox "Invalid value in TextBox1"
Exit Sub
End Select
Dim ImagetoChop As Object
Dim TempFilePath As String ' Assuming TempFilePath is defined elsewhere
Dim TempPicturePath As String ' Assuming TempPicturePath is defined elsewhere
Set ImagetoChop = CreateObject("WIA.ImageFile")
ImagetoChop.LoadFile TempFilePath
' Calculate the crop dimensions
XCrop = (ImagetoChop.Width / Image1.Width) * X
YCrop = (ImagetoChop.Height / Image1.Height) * Y
CLeft = WorksheetFunction.Max(0, XCrop - ScaleFactor)
CRight = WorksheetFunction.Max(0, ImagetoChop.Width - XCrop - ScaleFactor)
CTop = WorksheetFunction.Max(0, YCrop - ScaleFactor)
CBottom = WorksheetFunction.Max(0, ImagetoChop.Height - YCrop - ScaleFactor)
' Position the magnified image
Image2.Left = Image1.Left + X - (Image1.Width / 3)
Image2.Top = Image1.Top + Y - (Image1.Height / 3)
' Crop the image
Crop_Image TempFilePath, TempPicturePath, CLeft, CTop, CRight, CBottom
' Load the cropped image into Image2
Image2.Picture = LoadPicture("")
Image2.Picture = LoadPicture(TempPicturePath)
' Resize Image2 to maintain aspect ratio
Image2.Width = 500
Image2.Height = 500
If Image2.Picture.Width > Image2.Picture.Height Then
Image2.Width = (Image2.Picture.Width / Image2.Picture.Height) * Image2.Width
ElseIf Image2.Picture.Height > Image2.Picture.Width Then
Image2.Height = (Image2.Picture.Height / Image2.Picture.Width) * Image2.Height
End If
Exit Sub
ErrorHandler:
MsgBox "An error occurred: " & Err.Description
Exit Sub
End Sub
Sub Crop_Image(StartImage As String, FinishImage As String, CLeft As Long, CTop As Long, CRight As Long, CBottom As Long)
On Error GoTo ErrorHandler
' Declare variables
Dim ImagetoChop As Object
Dim Chopper As Object
Dim SaveCropImage As String
' Create WIA objects
Set ImagetoChop = CreateObject("WIA.ImageFile")
Set Chopper = CreateObject("WIA.ImageProcess")
' Load the image file to crop
ImagetoChop.LoadFile StartImage
' Add crop filter to the image process
Chopper.Filters.Add Chopper.FilterInfos("Crop").FilterID
' Set the crop properties
Chopper.Filters(1).Properties("Bottom") = CBottom
Chopper.Filters(1).Properties("Right") = CRight
Chopper.Filters(1).Properties("Left") = CLeft
Chopper.Filters(1).Properties("Top") = CTop
' Apply the crop to the image
Set ImagetoChop = Chopper.Apply(ImagetoChop)
' Specify the filename to save the cropped image
SaveCropImage = FinishImage
' Check if the file already exists and delete it
If Len(Dir(SaveCropImage)) > 0 Then Kill SaveCropImage
' Save the cropped image
ImagetoChop.SaveFile SaveCropImage
' Exit the subroutine
Exit Sub
ErrorHandler:
' Display error message
MsgBox "An error occurred: " & Err.Description
End Sub
Hope this helps somebody else, there doesn't seem to be much current information out there for this.