文字の描画の文字間隔の調整その4＿1／2 ( ソフトウェア ) - 午後わてんのブログ - Yahoo!ブログ
↑の2ページ目がこのページ
Private Function DrawInfo描画座標情報(bmp As Bitmap) As QuartetSpace上下左右の空白2 Dim reInte As QuartetSpace上下左右の空白2 With reInte .RightLength = New List(Of Integer) .RightPoints = New List(Of Integer) .LeftLength = New List(Of Integer) .LeftPoints = New List(Of Integer) .TopLength = New List(Of Integer) .TopPoints = New List(Of Integer) .BottomLength = New List(Of Integer) .BottomPoints = New List(Of Integer) Dim w As Integer = bmp.Width Dim h As Integer = bmp.Height Dim rect As New Rectangle(0, 0, bmp.Width, bmp.Height) Dim bmpData As BitmapData = bmp.LockBits(rect, ImageLockMode.ReadOnly, bmp.PixelFormat) Dim ptr As IntPtr = bmpData.Scan0 'Bitmapデータが在るメモリのアドレス？ Dim data As Integer = bmpData.Stride * h - 1 '入れ物の大きさ、Strideはbmp.width＊4になる？ Dim pixels(data) As Byte '入れ物 Runtime.InteropServices.Marshal.Copy(ptr, pixels, 0, pixels.Length) '入れ物にデータが入る、コピー Dim pos As Integer = 0 '入れ物のアドレス指定用 Dim x, y As Integer 'Dim isFind As Boolean = False '上限、下限見つかったよフラグ Dim cnt As Integer = 0 'カウント用 'Dim min As Integer reInte.Left = w '最小値用 reInte.Top = h '最小値用 '右端から探査、右側輪郭 For y = 0 To h - 1 For x = w - 1 To 0 Step -1 pos = y * bmpData.Stride + x * 4 If pixels(pos + 3) <> 0 Then '透明以外のピクセルなら(色が付いていたら) '.RightLength.Add(w - x) '場所を記録して次のラインへ .RightLength.Add(w - 1 - x) 'こっちかなあ .RightPoints.Add(x) Exit For End If cnt += 1 '透明ピクセルならカウントアップ Next 'すべて空白だったら-1を入れる If cnt = w Then 'カウント数が画像幅と同じならそのラインは全て空白なので-1を記録して次のラインへ .RightPoints.Add(-1) .RightLength.Add(-1) End If cnt = 0 Next '左端 For y = 0 To h - 1 For x = 0 To w - 1 pos = y * bmpData.Stride + x * 4 If pixels(pos + 3) <> 0 Then .LeftLength.Add(x) .LeftPoints.Add(x) If .Left > x Then '左の最小値用、左端のピクセルのＸ座標 .Left = x End If Exit For End If cnt += 1 Next If cnt = w Then 'カウント数が画像幅と同じならそのラインは全て空白なので-1を記録して次のラインへ .LeftLength.Add(-1) .LeftPoints.Add(-1) End If cnt = 0 Next '上 For x = 0 To w - 1 For y = 0 To h - 1 pos = y * bmpData.Stride + x * 4 If pixels(pos + 3) <> 0 Then .TopLength.Add(y) .TopPoints.Add(y) If .Top > y Then .Top = y End If Exit For End If cnt += 1 Next If cnt = h Then 'カウント数が画像幅と同じならそのラインは全て空白なので-1を記録して次のラインへ .TopLength.Add(-1) .TopPoints.Add(-1) End If cnt = 0 Next '下側 For x = 0 To w - 1 For y = h - 1 To 0 Step -1 pos = y * bmpData.Stride + x * 4 If pixels(pos + 3) <> 0 Then '.BottomLength.Add(h - y) .BottomLength.Add(h - 1 - y) 'Rightに続いてこっちも-1かなあ .BottomPoints.Add(y) Exit For End If cnt += 1 Next If cnt = h Then 'カウント数が画像幅と同じならそのラインは全て空白なので-1を記録して次のラインへ .BottomLength.Add(-1) .BottomPoints.Add(-1) End If cnt = 0 Next bmp.UnlockBits(bmpData) .Bottom = .BottomPoints.Max .Right = .RightPoints.Max .OutSize = New Size(bmp.Size) .InSize = New Size(.Right - .Left, .Bottom - .Top) End With Return reInte End Function
Private Sub Button5_Click(sender As Object, e As EventArgs) Handles Button5.Click Me.ListBox1.Items.Clear() 'リストボックスの初期化 Me.ListBox1.Anchor = AnchorStyles.Top Or AnchorStyles.Left Or AnchorStyles.Right Me.PictureBox1.Height = 178 Me.PictureBox1.Width = 400 Dim str As String = "Pixtack紫陽花" '文字の指定 str = "リストに追加しつつ" str = "ターン" 'str = "ショ" 'str = "ソノ人" 'str = "一二三" Dim w As Integer = Me.PictureBox1.Width Dim h As Integer = Me.PictureBox1.Height Dim bmp As New Bitmap(w, h) Dim g As Graphics = Graphics.FromImage(bmp) 'g.TextRenderingHint = Drawing.Text.TextRenderingHint.AntiAlias Dim b As New SolidBrush(Color.Black) Dim font As New Font("Meiryo UI", 30, FontStyle.Regular) Dim rect As New Rectangle(New Point(0, 0), New Size(w, h)) Dim sf As New StringFormat() Dim sizefCanvas As SizeF = g.MeasureString(str, font, New PointF(0, 0), sf) Dim sizeCancas As Size = sizefCanvas.ToSize 'このToSizeは切り捨て？ sizeCancas = New Size(Math.Ceiling(sizefCanvas.Width + 1), Math.Ceiling(sizefCanvas.Height + 1)) '+1は必要ない Dim rectC As New RectangleF(New PointF(0, 0), sizefCanvas) Dim wRectF As RectangleF '1文字の描画範囲用 Dim wRect As Rectangle Dim drawRange As New List(Of QuartetSpace上下左右の空白2) 'コレクション Dim bmpList As New List(Of Bitmap) '文字画像コレクション Const WORD_SPACE As Integer = 0 '指定マージン '1文字ごとに描画してDrawRange描画範囲上下左右getPixel版に渡して上下左右を取得してDrawLimit描画範囲のリストに追加しつつリストボックスに表示 '描画位置の情報集め For i As Integer = 0 To str.Length - 1 bmp = New Bitmap(w, h) g = Graphics.FromImage(bmp) 'g.TextRenderingHint = Drawing.Text.TextRenderingHint.AntiAlias'アンチエイリアス 'g.DrawString(str.Chars(i), font, b, Rectangle.Ceiling(rectC), sf) '文字の描画 wRectF = New RectangleF(New PointF(0, 0), g.MeasureString(str.Chars(i), font, New PointF(0, 0), sf)) '描画範囲 'wRect = Rectangle.Round(wRectF) 'RectangleFからRectangleにRoundで変換、Ceilingの方がいい？ wRect = Rectangle.Ceiling(wRectF) bmp = New Bitmap(wRect.Width + 1, wRect.Height + 1) 'Bitmap作り直し、＋1は必要？→必要ない g = Graphics.FromImage(bmp) 'Graphicsも作り直し g.DrawString(str.Chars(i), font, b, wRect, sf) '文字描画 drawRange.Add(DrawInfo描画座標情報(bmp)) '描画した画像から色のついたPixelを探して上下左右の一番外側をコレクションに追加 'Me.ListBox1.Items.Add(str.Chars(i) & " = " & drawRange.Item(i).myString1()) 'リストボックスに表示 bmpList.Add(bmp) '描画した画像をコレクションに追加 Next ''描画位置の情報を元にして全部の文字を描画 ''E:\オレ\エクセル\VisualBasicでアプリ作成2.xlsm_文字_$A$494 bmp = New Bitmap(w, h) g = Graphics.FromImage(bmp) Dim drawPoint As New Point(-(drawRange(0).Left) + WORD_SPACE, 0) g.DrawImage(bmpList(0), drawPoint) '1文字目描画 Dim lengthMin As Integer '前の文字に近づける距離 Dim len As New List(Of Integer) For i = 1 To str.Length - 1 For j As Integer = 0 To sizeCancas.Height - 1 'お互いの同じライン上に色付きピクセルがあるときだけコレクションに追加 If drawRange(i - 1).RightLength(j) <> -1 AndAlso drawRange(i).LeftLength(j) <> -1 Then len.Add(drawRange(i - 1).RightLength(j) + drawRange(i).LeftLength(j)) End If Next If len.Count <> 0 Then lengthMin = len.Min '空白文字以外の場合に近づける距離 Else lengthMin = 0 '空白文字の場合 End If '描画ポイント決定 '前回の描画のポイント＋一個前の文字の描画幅－近づける距離＋指定空間 drawPoint.X = drawPoint.X + drawRange(i - 1).OutSize.Width - lengthMin + WORD_SPACE len.Clear() g.DrawImage(bmpList(i), drawPoint) '文字の描画 Next Me.PictureBox1.Image = bmp g.Dispose() b.Dispose() sf.Dispose() End Sub
ファイル名： 文字の描画位置、範囲_20150409.7z
