Public Sub Actual_AutoSize(ByVal AxLabel As Label)
If AxLabel.Text.Trim.Length = 0 Then Exit Sub
Dim gp As New Drawing2D.GraphicsPath
Dim sf As New StringFormat
Dim rgn As Region
sf.LineAlignment = StringAlignment.Near
sf.Alignment = StringAlignment.Near
gp.AddString(AxLabel.Text, AxLabel.Font.FontFamily, AxLabel.Font.Style, AxLabel.Font.SizeInPoints, New Point(0, 0), sf)
rgn = New Region(gp)
Dim bit As New Bitmap(AxLabel.Width, AxLabel.Height)
AxLabel.DrawToBitmap(bit, AxLabel.DisplayRectangle)
Dim x As Integer = rgn.GetBounds(AxLabel.CreateGraphics).X
Dim y As Integer = rgn.GetBounds(AxLabel.CreateGraphics).Y
Dim XX, YY As Integer
For XX = x To bit.Width - 1
For YY = y To bit.Height - 1
If bit.GetPixel(XX, YY).ToArgb.ToString <> AxLabel.BackColor.ToArgb.ToString Then
GoTo 100
End If
Next
Next
100:
Dim FirstX As Integer = XX
For XX = bit.Width - 1 To 0 Step -1
For YY = y To bit.Height - 1
If bit.GetPixel(XX, YY).ToArgb.ToString <> AxLabel.BackColor.ToArgb.ToString Then
GoTo 200
End If
Next
Next
200:
Dim SecondX As Integer = XX
For YY = y To bit.Height - 1
For XX = x To bit.Width - 1
If bit.GetPixel(XX, YY).ToArgb.ToString <> AxLabel.BackColor.ToArgb.ToString Then
GoTo 300
End If
Next
Next
300:
Dim FirstY As Integer = YY
For YY = bit.Height - 1 To 0 Step -1
For XX = x To bit.Width - 1
If bit.GetPixel(XX, YY).ToArgb.ToString <> AxLabel.BackColor.ToArgb.ToString Then
GoTo 400
End If
Next
Next
400:
Dim SecondY As Integer = YY
AxLabel.Region = New Region(New Rectangle(FirstX, FirstY, SecondX - FirstX, SecondY - FirstY))
gp = Nothing
sf = Nothing
rgn = Nothing
bit = Nothing
x = Nothing
y = Nothing
XX = Nothing
YY = Nothing
FirstX = Nothing
SecondX = Nothing
FirstY = Nothing
SecondY = Nothing
End Sub
نتیجه کار:
دقت این متد 100% می باشد و سرعت آن هم در حد چند میلی ثانیه می باشد.
ممنون.
اتو سایز واقعی - Actual AutoSize
پاسخ با نقل قول
نوشته شده توسط shalineh
