Определение размера символа для текущего шрифта - VB
Формулировка задачи:
Используя DirectX, я вывожу текст на поверхность:
ddsBack.DrawText kx, ky, Value, False
Я хочу, что бы текст помещался в определенный объект, а не вылезал за его пределы. Поскольку каждый символ имеет свой размер, как узнать размер символа для данного шрифта? И как менять шрифт в DX ?
Решение задачи: «Определение размера символа для текущего шрифта»
textual
Листинг программы
Option Explicit
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function GetTextExtentPoint32 Lib "gdi32" Alias "GetTextExtentPoint32A" (ByVal hdc As Long, ByVal lpsz As String, ByVal cbString As Long, lpSize As SIZE) As Long
Private Type SIZE
cx As Long
cy As Long
End Type
Public Function vbGetTextWidth(ByVal strSource As String, Font As StdFont) As Long
Dim myFont As IFont ' We want the IFont interface
Dim hFont As Long
Dim mySize As SIZE
Dim hdc As Long
Set myFont = Font ' switch interface
myFont.SIZE = Font.SIZE * 1000 ' increases accuracy since resultant mysize only hold longs
hdc = CreateCompatibleDC(0) ' compatible with screen display
hFont = SelectObject(hdc, myFont.hFont)
GetTextExtentPoint32 hdc, strSource, Len(strSource), mySize
'Clean up as much as we need to
SelectObject hdc, hFont
DeleteDC hdc
vbGetTextWidth = mySize.cx / 1000 ' bring back to normal
End Function
Private Sub Command1_Click()
Dim lngTextWidth As Long
lngTextWidth = vbGetTextWidth("A", Me.Font)
End Sub