vb.netを使用してイメージにテキストを追加します。フォントサイズ計算のエラー

Question

小さなアプリケーションを書いて、指定したテキストを画像の最後に追加しようとしています。このテキストは元のイメージの上に追加することはできず、元のイメージのフレームサイズに加えて配置する必要があります。

これはほとんどの場合うまく動作しますが、別のカメラを使用してテストした場合、同じ結果がスクリプトで生成されましたが、画像の解像度がはるかに優れていたためです。フォントはあまりにも小さくて信憑性がありませんでした。

必要なフォントサイズを計算するためのコーディングを追加しましたが、これは小さい解像度の画像ではうまくいくように見えますが、高品質の画像には大きすぎるフォントが生成されます。

これは、フォントサイズを計算するための私のコード、saveコマンドがオリジナルの圧縮ステータス、または私が考慮していない他のものの圧縮ステータスを変更したことが原因である可能性があります。

いくつかのガイダンスがずっとappreciteだろう...

Dim objImage As Bitmap 
Dim objNewImage As Bitmap 
Dim objGraphics As Graphics 
Dim objFont As Font 
Dim szTextSize As Size 
Dim intPictureHeightToAdd As Integer 
Dim emFontSize As Single 

' load image passed as full path string, return 1 if failure 
objImage = Bitmap.FromFile(v_strFullFileName, True) 

' height to add will be 5% 
intPictureHeightToAdd = (objImage.Height * 5)/100 
' create a new image with the same dimensions plus space for text and same pixel format 
objNewImage = New Bitmap(objImage.Width, objImage.Height + intPictureHeightToAdd, objImage.PixelFormat) 
' set the resolution to the same as existing 
objNewImage.SetResolution(objImage.HorizontalResolution, objImage.VerticalResolution) 

' create a graphic object for image manipultion 
objGraphics = objGraphics.FromImage(objNewImage) 
' place existing image into graphic top left. This will leave space at bottom for text 
objGraphics.DrawImage(objImage, 0, 0) 

' add meta data to intended new image from existing 
For Each propItem In objImage.PropertyItems 
    objNewImage.SetPropertyItem(propItem) 
Next propItem 

' create the font and measure this, comparing to height of image. (if image is to large, and font too small; it will be unredable) 
emFontSize = 10.0F 
Do 
    emFontSize += 1 
    objFont = New Font("Courier", emFontSize) 
    szTextSize = TextRenderer.MeasureText(m_strTextToAppend, objFont) 
Loop Until szTextSize.Height >= intPictureHeightToAdd 
emFontSize -= 10 
objFont = New Font("Courier", emFontSize) 

' draw a rectangle with text in space remaining (set text to red as most likely to stand out in background 
objGraphics.DrawString(m_strTextToAppend, objFont, Brushes.Red, New RectangleF(0, objImage.Height, objImage.Width, intPictureHeightToAdd)) 

objImage.Dispose() 
' save font added 

objNewImage.Save(v_strFullFileName, Imaging.ImageFormat.Jpeg) 

'dispose of new image as now saved and graphics object 
objNewImage.Dispose() 
objGraphics.Dispose() 

Answer 1

私はTextRendererは、あなたのイメージが使用しているDPI知らない、それはDPIとしなければならないと思います。 MeasureStringを試してみてください。

このサンプルでは、​​TextRendererはDPIごとに同じ高さを返し、MeasureStringは適切な高さを返します。

Sub Main() 

    Dim toDraw As String = "A" 
    Dim image As Bitmap 
    Dim g As Graphics 
    Dim f As Font 

    image = New Bitmap(100, 100) 
    g = Graphics.FromImage(image) 
    f = New Font("Arial", 16) 

    Console.WriteLine(TextRenderer.MeasureText(toDraw, f)) ' height = 25 
    Console.WriteLine(g.MeasureString(toDraw, f)) ' height = 26.5 

    g.DrawString(toDraw, f, Brushes.Black, New PointF(0, 0)) 
    image.Save("C:\a.jpg") ' Image with small A 

    image = New Bitmap(100, 100) 
    image.SetResolution(300, 300) 
    g = Graphics.FromImage(image) 
    f = New Font("Arial", 16) 

    Console.WriteLine(TextRenderer.MeasureText(toDraw, f)) ' height = 25 
    Console.WriteLine(g.MeasureString(toDraw, f)) ' height = 82.8 

    g.DrawString(toDraw, f, Brushes.Black, New PointF(0, 0)) 
    image.Save("C:\b.jpg") ' Image with big A 

    Console.ReadLine() 

End Sub