我正在尝试使用此P / Invoke调用获取字体字距调整对:
Imports System.Runtime.InteropServices
Public Class Kerning
Structure KERNINGPAIR
Public wFirst As UInt16
Public wSecond As UInt16
Public iKernelAmount As UInt32
End Structure
<DllImport("gdi32.dll")> _
Private Shared Function GetKerningPairs(hdc As IntPtr,
nNumPairs As UInteger, <Out> lpkrnpair As KERNINGPAIR()) As UInteger
End Function
Sub ExaminePairs()
Dim f As Font
For Each myFontFamily In System.Drawing.FontFamily.Families
f = New Font(myFontFamily, 25)
Dim pairs As UInteger = 0
Dim pairsArray() As KERNINGPAIR
ReDim pairsArray(pairs)
Dim a = GetKerningPairs(f.ToHfont(), pairs, Nothing)
If a <> 0 Then
MsgBox("Found!")
End If
f.Dispose()
Next
End Sub
End Class
只要找到具有已定义字距调整对的字体,ExamineParis函数就会显示一个消息框(根据:https://msdn.microsoft.com/en-us/library/windows/desktop/dd144895(v=vs.85).aspx) 但它似乎总是返回0。
我需要找到一种方法来获取给定字体的所有字距对(有多少个,然后是它们的结构)。
有谁知道怎么做?
答案 0 :(得分:2)
接受的答案here显示了如何从VB.NET调用GetKerningPairs
。这里修改了代码以适合您的代码:
Imports System.Drawing
Imports System.Runtime.InteropServices
Public Class Kerning
<StructLayout(LayoutKind.Sequential)>
Structure KERNINGPAIR
Public wFirst As Short
Public wSecond As Short
Public iKernelAmount As Integer
End Structure
<DllImport("gdi32.dll", SetLastError:=True, CallingConvention:=CallingConvention.Winapi)>
Public Shared Function GetKerningPairs(ByVal hdc As IntPtr, ByVal nPairs As Integer, <MarshalAs(UnmanagedType.LPArray, SizeParamIndex:=1)> <Out()> ByVal pairs() As KERNINGPAIR) As Integer
End Function
<DllImport("gdi32.dll")>
Private Shared Function SelectObject(ByVal hdc As IntPtr, ByVal hObject As IntPtr) As IntPtr
End Function
Public Shared Function GetKerningPairs(ByVal font As Font) As IList(Of KERNINGPAIR)
Dim pairs() As KERNINGPAIR
Using g As Graphics = Graphics.FromHwnd(IntPtr.Zero)
g.PageUnit = GraphicsUnit.Pixel
Dim hdc As IntPtr = g.GetHdc
Dim hFont As IntPtr = font.ToHfont
Dim old As IntPtr = SelectObject(hdc, hFont)
Try
Dim numPairs As Integer = GetKerningPairs(hdc, 0, Nothing)
If numPairs > 0 Then
pairs = New KERNINGPAIR(numPairs - 1) {}
numPairs = GetKerningPairs(hdc, numPairs, pairs)
Return pairs
Else
Return Nothing
End If
Finally
old = SelectObject(hdc, old) ' replace whatever object was selected in the dc
End Try
End Using
End Function
Sub ExaminePairs()
For Each myFontFamily In FontFamily.Families
Try
Using f = New Font(myFontFamily, 25)
Dim pairs = GetKerningPairs(f)
If pairs IsNot Nothing Then
Debug.Print("#Pairs: {0}", pairs.Count)
Else
Debug.Print("No pairs found")
End If
End Using
Catch ex As Exception
Debug.Print("Error: {0} for: {1}", ex.Message, myFontFamily.Name)
End Try
Next
End Sub
End Class