投稿日 | : 2005/04/13(Wed) 17:49 |
投稿者 | : 花ちゃん |
Eメール | : |
URL | : |
タイトル | : 下記をお試しあれ |
Private Function GetFontSize(ByVal myString As String, _
ByVal ctlWid As Long, _
ByVal ctlHei As Long) As Single
Dim fh(12) As Single, fw(12) As Single, FS(12) As Single, tw(12) As Integer
Dim n As Integer, i1 As Long, i As Single, j As Long
Dim Ln As Integer, meFS As Single
n = -1
meFS = Me.FontSize
'上下左右の余白分を考慮
ctlWid = ctlWid - 0: ctlHei = ctlHei - 90
For i = 6 To 15 Step 0.75 'フォントサイズの有効範囲
Me.FontSize = i
n = n + 1
fw(n) = Me.TextWidth(myString)
fh(n) = Me.TextHeight(myString)
tw(n) = Me.TextHeight("あ")
FS(n) = i
Next i
Me.FontSize = meFS
For j = 8 To 4 Step -1 'フォントサイズ 9〜12
For i1 = 1 To 4 '1行から4行までの表示の場合
'折り返し時の表示できない分を半角1文字分考慮
If fw(j) < (ctlWid - (tw(j) / 2)) * i1 Then
If (ctlHei \ fh(j) >= i1) Then
'表示行数を取得
' Ln = SendMessage(Text1.hWnd, EM_GETLINECOUNT, 0&, 0&)
'Text1.Height の自動調整する場合は下記のように
' Text1.Height = (Ln * fh(j)) + 90
GetFontSize = FS(j)
Exit Function
End If
End If
Next i1
Next j
If GetFontSize < 9 Then
MsgBox "指定のフォントサイズで表示できません"
GetFontSize = 3
End If
End Function
Private Sub Form_Load()
Me.FontName = "MS Pゴシック"
Me.FontSize = 9
With Text1
'テキストボックスのワードラップを抑止する
Call SetNonWordWrap(.hWnd)
.Width = 2000
.Height = 1000
.Text = ""
.BorderStyle = 1
End With
End Sub
Private Sub Text1_LostFocus()
Text1.FontSize = GetFontSize(Text1.Text, 2000, 1000)
End Sub