使用缩放相对于图像调整 Picturebox 上绘制的矩形的大小答案

【问题标题】：Resizing drawn rectangle on Picturebox relative to image using Zoom使用缩放相对于图像调整 Picturebox 上绘制的矩形的大小
【发布时间】：2014-10-29 03:25:31
【问题描述】：

我有一个可以在其上绘制矩形的图片框，并且我拥有它以便记录矩形尺寸（以百分比为单位），以便如果表单的大小发生变化，那么矩形大小也会发生变化（参见下面的代码文字）

但是，当我在“缩放”模式下将图片框设置为“缩放”模式时，矩形在调整大小时不匹配（请参见此处：第一个，在图像http://i1262.photobucket.com/albums/ii602/bmgh85/Size1.png 上定义点上的角，然后在调整表单大小后的第二个@ 987654322@

它在“拉伸”模式下可以正常工作，但是会扭曲图像，这对我没有用（我需要保持比例）。如何操作我的代码以使其按预期工作？

Private x, y As Integer
Private Rct As New Rectangle(0, 0, 0, 0)

Private Sub PictureBox1_MouseDown(ByVal sender As Object, ByVal e As System.Windows.Forms.MouseEventArgs) Handles PictureBox1.MouseDown
    If e.Button = Windows.Forms.MouseButtons.Left Then
        x = e.X
        y = e.Y
    End If
End Sub

Private Sub PictureBox1_MouseMove(ByVal sender As Object, ByVal e As System.Windows.Forms.MouseEventArgs) Handles PictureBox1.MouseMove
    If e.Button = Windows.Forms.MouseButtons.Left Then
        Rct.X = Math.Min(x, e.X)
        Rct.Y = Math.Min(y, e.Y)
        Rct.Height = Math.Abs(e.Y - y)
        Rct.Width = Math.Abs(e.X - x)
        PictureBox1.Refresh()
        PictureBox1.Tag = calculatePercent(Rct.X, Rct.Y, Rct.Height, Rct.Width, PictureBox1)
    End If
End Sub

Private Sub PictureBox1_MouseUp(sender As Object, e As MouseEventArgs) Handles PictureBox1.MouseUp
    MsgBox(PictureBox1.Tag)
    Dim lst1 As List(Of Int32) = returnPercent(PictureBox1.Tag)
    For i = 0 To lst1.Count - 1
        MsgBox(lst1(i))
    Next
End Sub

Private Sub PictureBox1_Paint(ByVal sender As System.Object, ByVal e As System.Windows.Forms.PaintEventArgs) Handles PictureBox1.Paint
    e.Graphics.DrawRectangle(Pens.Red, Rct)
End Sub

Function calculatePercent(ByVal X As Long, Y As Long, Ht As Long, Wth As Long, pBox As PictureBox)
    Dim wPercent As Long = 100 * Wth / pBox.Width
    Dim hPercent As Long = 100 * Ht / pBox.Height
    Dim yPercent As Long = 100 * Y / pBox.Height
    Dim xPercent As Long = 100 * X / pBox.Width
    Return "X:" & xPercent & ", Y:" & yPercent & ", Ht:" & hPercent & ", Wth:" & wPercent
End Function

Function returnPercent(ByVal myTag As String)
    Dim lst As New List(Of Int32)
    Dim getX As String = getNum(Mid(myTag, InStr(myTag, "X:"), InStr(myTag, ", Y:") - InStr(myTag, "X:")))
    Dim getY As String = getNum(Mid(myTag, InStr(myTag, ", Y:"), InStr(myTag, ", Ht:") - InStr(myTag, ", Y:")))
    Dim getH As String = getNum(Mid(myTag, InStr(myTag, ", Ht:"), InStr(myTag, ", Wth:") - InStr(myTag, ", Ht:")))
    Dim getW As String = getNum(Mid(myTag, InStr(myTag, ", Wth:")))
    lst.Add(getX)
    lst.Add(getY)
    lst.Add(getH)
    lst.Add(getW)
    Return lst
End Function

Function getNum(ByVal txt As String)
    Dim rtn As String = vbNullString
    Dim coln As MatchCollection = Regex.Matches(txt, "\d+")
    For Each mtch As Match In coln
        rtn = rtn & mtch.ToString
    Next
    Return Convert.ToInt32(rtn)
End Function

Private Sub PictureBox1_SizeChanged(sender As Object, e As EventArgs) Handles PictureBox1.SizeChanged
    Dim lst As New List(Of Int32)
    If PictureBox1.Tag <> "" Then
        lst = returnPercent(PictureBox1.Tag)
        Rct.X = lst(0) * PictureBox1.Width / 100
        Rct.Y = lst(1) * PictureBox1.Height / 100
        Rct.Height = lst(2) * PictureBox1.Height / 100
        Rct.Width = lst(3) * PictureBox1.Width / 100
        PictureBox1.Refresh()
    End If
End Sub

【问题讨论】：

我们是双胞胎！我之前有一个非常相似的问题：stackoverflow.com/questions/26471376/…
尽管问题不同，但我认为您的问题是您没有使用 graphics.fromimage 直接在图像上绘图（很多人都推荐使用 graphics.fromimage）。我会尝试这样做，矩形将自动根据您的图像调整大小（因为它是在位图上绘制的）。
问题是我在表单上的其他 3 个地方使用了图像，但只想让这个实例上有矩形（因此我需要这样做并存储百分比值稍后再打回来）。如果我这样做，那么它不会涉及保存原始和编辑的图像，这意味着在磁盘上使用更多空间吗？或者它是否仍然只在那个实例上给我想要的效果并且仍然被即时调用？
这将涉及保存副本位图/图像，是的。但我最终用我的照片（最高可达 1980x680）做到了这一点，并没有看到滞后或大空间问题。但是，我不知道你的要求是什么。
我的老板对硬盘占用空间非常讲究。如果某些东西可以保存得更小，那么它必须是（通常以牺牲质量为代价——他在 IT 或图形方面没有太多知识）。想我可能只是想到了一个解决方案。如果我使用缩放，我应该仍然能够获得图像尺寸（不是图片框）并从中计算出 %。顺便说一句，在您的问题中，您在应用程序中使用什么相机？开始在我正在做的事情上安装相机插件，但使用 API 调用会遇到很多麻烦，因为这些对于 XP 以上的任何驱动程序都是喜怒无常的

标签： vb.net picturebox

【解决方案1】：

我有一些代码可以帮助你：

    ' Rectangle to draw
Private Rct As New Rectangle(0, 0, 0, 0)
Private offsetX As Integer = 0
Private offsetY As Integer = 0

Sub Main() Handles MyBase.Load

    ' Some image to use
    MiniPictureBox.Image = My.Resources.P6130003
    MainPictureBox.Image = My.Resources.P6130003

End Sub

Private Sub MiniPictureBox_MouseDown(sender As Object, e As MouseEventArgs) Handles MiniPictureBox.MouseDown

    If e.Button = Windows.Forms.MouseButtons.Left Then

        If Not Rct.Contains(e.Location) Then
            ' New rectangle
            Rct.Location = New Point(e.X, e.Y)
        Else
            ' Moving a rectangle
            offsetX = Rct.X - e.X
            offsetY = Rct.Y - e.Y
        End If

    ElseIf e.Button = Windows.Forms.MouseButtons.Right Then

        ' Clears the screen of a rectangle
        Rct = New Rectangle(0, 0, 0, 0)
        MiniPictureBox.Invalidate()

    End If

End Sub

Private Sub MiniPictureBox_MouseMove(sender As Object, e As MouseEventArgs) Handles MiniPictureBox.MouseMove

    ' Event handler to update the picture of the rectangle
    If e.Button = Windows.Forms.MouseButtons.Left Then

        If Rct.Contains(e.Location) Then
            ' Move the box
            Rct.X = e.X + offsetX
            Rct.Y = e.Y + offsetY
            MainPictureBox.Invalidate()
        Else
            ' Update the size of the box
            Rct.Width = e.X - Rct.X
            Rct.Height = e.Y - Rct.Y
        End If

        MiniPictureBox.Invalidate()

    End If


End Sub

Private Sub MiniPictureBox_MouseUp(sender As Object, e As MouseEventArgs) Handles MiniPictureBox.MouseUp

    ' Event handler to call the paint event for runtime display
    MiniPictureBox.Invalidate()
    MainPictureBox.Invalidate()

End Sub

Private Sub MiniPictureBox_Paint(sender As Object, e As PaintEventArgs) Handles MiniPictureBox.Paint

    Dim myPen As Pen = New Pen(Brushes.Red, 2)
    e.Graphics.DrawRectangle(myPen, Rct)

End Sub

Private Sub MainPictureBox_Paint(sender As Object, e As PaintEventArgs) Handles MainPictureBox.Paint

    If Rct.Width > 0 Then
        Dim biggerRec As Rectangle = CalculateRectangle(MainPictureBox)

        Dim myPen As Pen = New Pen(Brushes.Red, 2)
        e.Graphics.DrawRectangle(myPen, biggerRec)
    End If

End Sub

Private Function CalculateRectangle(currentPicture As PictureBox) As Rectangle

    Try
        Dim newWidth As Integer = (Rct.Width / MiniPictureBox.Width) * currentPicture.Image.Width
        Dim newHeight As Integer = (Rct.Height / MiniPictureBox.Height) * currentPicture.Image.Height
        Dim newX As Integer = (Rct.X / MiniPictureBox.Width) * currentPicture.Image.Width
        Dim newY As Integer = (Rct.Y / MiniPictureBox.Height) * currentPicture.Image.Height
        Return New Rectangle(newX, newY, newWidth, newHeight)
    Catch ex As Exception
        MessageBox.Show(ex.Message + Environment.NewLine + Environment.NewLine + ex.StackTrace)
    End Try

End Function

此代码将允许您创建、移动和清除矩形。需要注意的一点是在更改矩形大小的计算中，您必须确保为任何算术异常正确插入异常处理。

【讨论】：