How to get font kerning pairs in .net

Question

I'm trying to get font kerning pairs by using this P/Invoke call:

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

The ExamineParis function should show a messagebox whenever a font with defined kerning pairs is found (according to this: https://msdn.microsoft.com/en-us/library/windows/desktop/dd144895(v=vs.85).aspx ) But it seems to return always 0.

I need to find a way to get all kerning pairs of a given font (how many there are, and then their structure).

Does anyone know how it could be done?

Answer 1

The accepted answer here shows how to call GetKerningPairs from VB.NET. Here's that code modified to fit with yours:

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