DoboWiki

'Imports System.Drawing
 
''' <summary>
''' Graphics.DrawStringで文字列を描画した時の大きさと位置を正確に計測する
''' </summary>
''' <param name="g">文字列を描画するGraphics</param>
''' <param name="text">描画する文字列</param>
''' <param name="font">描画に使用するフォント</param>
''' <param name="proposedSize">これ以上大きいことはないというサイズ。
''' できるだけ小さくすること。</param>
''' <param name="stringFormat">描画に使用するStringFormat</param>
''' <returns>文字列が描画される範囲。
''' 見つからなかった時は、Rectangle.Empty。</returns>
Public Shared Function MeasureStringPrecisely(g As Graphics, _
        text As String, font As Font, proposedSize As Size, _
        stringFormat As StringFormat) As Rectangle
    '解像度を引き継いで、Bitmapを作成する
    Dim bmp As New Bitmap(proposedSize.Width, proposedSize.Height, g)
    'BitmapのGraphicsを作成する
    Dim bmpGraphics As Graphics = Graphics.FromImage(bmp)
    'Graphicsのプロパティを引き継ぐ
    bmpGraphics.TextRenderingHint = g.TextRenderingHint
    bmpGraphics.TextContrast = g.TextContrast
    bmpGraphics.PixelOffsetMode = g.PixelOffsetMode
    '文字列の描かれていない部分の色を取得する
    Dim backColor As Color = bmp.GetPixel(0, 0)
    '実際にBitmapに文字列を描画する
    bmpGraphics.DrawString(text, font, Brushes.Black, _
        New RectangleF(0.0F, 0.0F, proposedSize.Width, proposedSize.Height), _
        stringFormat)
    bmpGraphics.Dispose()
    '文字列が描画されている範囲を計測する
    Dim resultRect As Rectangle = MeasureForegroundArea(bmp, backColor)
    bmp.Dispose()
 
    Return resultRect
End Function
 
''' <summary>
''' 指定されたBitmapで、backColor以外の色が使われている範囲を計測する
''' </summary>
Private Shared Function MeasureForegroundArea(bmp As Bitmap, _
        backColor As Color) As Rectangle
    Dim backColorArgb As Integer = backColor.ToArgb()
    Dim maxWidth As Integer = bmp.Width
    Dim maxHeight As Integer = bmp.Height
 
    Dim x As Integer
    Dim y As Integer
 
    '左側の空白部分を計測する
    Dim leftPosition As Integer = -1
    For x = 0 To maxWidth - 1
        For y = 0 To maxHeight - 1
            '違う色を見つけたときは、位置を決定する
            If bmp.GetPixel(x, y).ToArgb() <> backColorArgb Then
                leftPosition = x
                Exit For
            End If
        Next
        If 0 <= leftPosition Then
            Exit For
        End If
    Next
    '違う色が見つからなかった時
    If leftPosition < 0 Then
        Return Rectangle.Empty
    End If
 
    '右側の空白部分を計測する
    Dim rightPosition As Integer = -1
    For x = maxWidth - 1 To leftPosition + 1 Step -1
        For y = 0 To maxHeight - 1
            If bmp.GetPixel(x, y).ToArgb() <> backColorArgb Then
                rightPosition = x
                Exit For
            End If
        Next
        If 0 <= rightPosition Then
            Exit For
        End If
    Next
    If rightPosition < 0 Then
        rightPosition = leftPosition
    End If
 
    '上の空白部分を計測する
    Dim topPosition As Integer = -1
    For y = 0 To maxHeight - 1
        For x = leftPosition To rightPosition
            If bmp.GetPixel(x, y).ToArgb() <> backColorArgb Then
                topPosition = y
                Exit For
            End If
        Next
        If 0 <= topPosition Then
            Exit For
        End If
    Next
    If topPosition < 0 Then
        Return Rectangle.Empty
    End If
 
    '下の空白部分を計測する
    Dim bottomPosition As Integer = -1
    For y = maxHeight - 1 To topPosition + 1 Step -1
        For x = leftPosition To rightPosition
            If bmp.GetPixel(x, y).ToArgb() <> backColorArgb Then
                bottomPosition = y
                Exit For
            End If
        Next
        If 0 <= bottomPosition Then
            Exit For
        End If
        y -= 1
    Next
    If bottomPosition < 0 Then
        bottomPosition = topPosition
    End If
 
    '結果を返す
    Return New Rectangle(leftPosition, topPosition, _
        rightPosition - leftPosition, bottomPosition - topPosition)
End Function
 
Private Shared Function MeasureForegroundArea(bmp As Bitmap) As Rectangle
    Return MeasureForegroundArea(bmp, bmp.GetPixel(0, 0))
End Function

'Imports System.Drawing
 
'表示する文字列
Dim s As String = "DOBON.NET"
 
'描画先とするImageオブジェクトを作成する
Dim canvas As New Bitmap(PictureBox1.Width, PictureBox1.Height)
'ImageオブジェクトのGraphicsオブジェクトを作成する
Dim g As Graphics = Graphics.FromImage(canvas)
g.SmoothingMode = System.Drawing.Drawing2D.SmoothingMode.HighQuality
g.TextRenderingHint = System.Drawing.Text.TextRenderingHint.AntiAlias
 
'フォントオブジェクトの作成
Dim fnt As New Font("Arial", 25, FontStyle.Italic)
'StringFormatオブジェクトの作成
Dim sf As New StringFormat()
 
'幅の最大値が1000ピクセルとして、文字列を描画するときの大きさを計測する
Dim stringSize As SizeF = g.MeasureString(s, fnt, 1000, sf)
'取得した文字列の大きさを使って四角を描画する
g.DrawRectangle(Pens.Red, 0, 0, stringSize.Width, stringSize.Height)
 
'より正確に大きさを計測する
Dim rect As Rectangle = MeasureStringPrecisely(g, s, fnt, canvas.Size, sf)
g.DrawRectangle(Pens.Blue, rect.Left, rect.Top, rect.Width, rect.Height)
 
'文字列を描画する
g.DrawString(s, fnt, Brushes.Black, 0, 0, sf)
 
'リソースを解放する
fnt.Dispose()
sf.Dispose()
g.Dispose()
 
'PictureBox1に表示する
PictureBox1.Image = canvas