Drawing rect in picturebox not done to right scale for mouse

问题

I currently have a picture box where the user will click and drag to draw a rectangle over an image (one that can be changed regularly). When they're done (mouse_up), I will display the relative points of the rect in a text box to the resolution.

So, for example, the user draws from top left (0,0) to bottom right of a 1920 x 680 image (picturebox.right, picturebox.bottom) for a rect, the text box will show (1920,680) for the end point. That's mostly just ratio stuff.

I am using the code from an answer of a previous question of mine (Having trouble drawing simple rectangle in picturebox) to draw it.

The Problem: The box doesn't follow the mouse since the images have to be done in stretch mode. They're usually pretty large (like 1920 x 680) and can't fit in a regular gui. There are multiple resolutions, so got to go dynamic with the ratios. Without editing, this code works great in normal mode, but that doesn't work for usability. So, when you draw the box, it's really small and not relative to the mouse (so I can't display the end point on the textboxes).

Here's an example of what I mean. I've dragged my mouse halfway across the image:

What I've tried: I've attempted to counter act it by ratios, but it still doesn't fix the displaying the end point issue, or does it really follow the mouse that well. It's usually off by at least 10 or so pixels to the left. Here's my adjusted code for that:

    Private Sub DrawRectangle(ByVal pnt As Point)

    Try
        Dim g As Graphics

        g = Graphics.FromImage(img)

        g.DrawImage(imgClone, 0, 0) 'we are clearing img with imgClone. imgClone contains the original image without the rectangles

        Dim w_ratio As Integer = Math.Floor(img.Width / pbZoneImage.Width)
        Dim h_ratio As Integer = Math.Floor(img.Height / pbZoneImage.Height)
        Dim customPen As New Pen(currentColor, 5)

        'If pnt.X = mouse_Down.X Or pnt.Y = mouse_Down.Y Then
        '    g.DrawLine(customPen, mouse_Down.X, mouse_Down.Y, pnt.X * w_ratio, pnt.Y * h_ratio)

        'Else
        theRectangle = New Rectangle(Math.Min(mouse_Down.X, pnt.X * w_ratio), Math.Min(mouse_Down.Y, pnt.Y * h_ratio),
                    Math.Abs(mouse_Down.X - pnt.X * w_ratio), Math.Abs(mouse_Down.Y - pnt.Y * h_ratio))

        g.DrawRectangle(customPen, theRectangle)

        'End If

        g.Dispose()

        pbZoneImage.Invalidate() 'draw img to picturebox


    Catch ex As Exception

    End Try

End Sub

I've also tried just getting the end display point (x,y) to match the relative end of the rectangle, but again it isn't working with the ratios.

Any ideas on how to make this work as well as it does in normal mode as it does in stretch? I'm also open to different controls or just any tips in general. Thanks!

回答1:

This can be done with many ways but the easiest is to use a picturebox with SizeMode = Normal. Load your images:

img = New Bitmap(pbZoneImage.Width, pbZoneImage.Height)

imgClone = My.Resources.... 'real dimensions

Dim g As Graphics = Graphics.FromImage(img)

'it will scale the image, no need for stretch mode
g.DrawImage(imgClone, 0, 0, pbZoneImage.Width, pbZoneImage.Height)

g.Dispose()

pbZoneImage.Image = img

Then draw normally:

Private Sub DrawRectangle(ByVal pnt As Point)

Try
    Dim g As Graphics

    g = Graphics.FromImage(img)

    g.DrawImage(imgClone, 0, 0, pbZoneImage.Width, pbZoneImage.Height) 'we are clearing img with imgClone. imgClone contains the original image without the rectangles

    Dim customPen As New Pen(currentColor, 5)

    'If pnt.X = mouse_Down.X Or pnt.Y = mouse_Down.Y Then
    '    g.DrawLine(customPen, mouse_Down.X, mouse_Down.Y, pnt.X * w_ratio, pnt.Y * h_ratio)

    'Else
    theRectangle = New Rectangle(Math.Min(mouse_Down.X, pnt.X), Math.Min(mouse_Down.Y, pnt.Y),
                Math.Abs(mouse_Down.X - pnt.X), Math.Abs(mouse_Down.Y - pnt.Y))

    g.DrawRectangle(customPen, theRectangle)

    'End If

    g.Dispose()

    pbZoneImage.Invalidate() 'draw img to picturebox


    Catch ex As Exception

    End Try

End Sub

In mouse up event scale to get the correct result:

Private Sub pbZoneImage_MouseUp(sender As System.Object, e As System.Windows.Forms.MouseEventArgs) Handles pbZoneImage.MouseUp
    Dim width, height As Integer

    width = CInt(Math.Abs(mouse_Down.X - e.X) * (imgClone.Width / pbZoneImage.Width))
    height = CInt(Math.Abs(mouse_Down.Y - e.Y) * (imgClone.Height / pbZoneImage.Height))

    TextBox1.Text = width.ToString + " " + height.ToString
End Sub

来源：https://stackoverflow.com/questions/26471376/drawing-rect-in-picturebox-not-done-to-right-scale-for-mouse