如何在 .net 中获取字体字距调整对

Question

我正在尝试通过使用此 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。

我需要找到一种方法来获取给定字体的所有字距调整对（有多少，然后是它们的结构）。

有人知道怎么做吗？

Answer 1

接受的答案 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