Finding Font Filename from Font Title

Well, all was going well with my code to create custom XPS documents, when I tried to be fancy with fonts. How to point the XPS engine at the correct font file so it could be included within the document as a resource??
I cannot yet find any APIs that help with this; any help would be appreciated.  Instead I managed to look up the registry for the name of the file associated with the font.  This is a bit of a hack, as font collections contained within one file probably will mess this up.
It works, sort of, and I wrote the code that calls this routine to use arial.ttf if all else fails, so there is a back up plan.
Here is the subroutine:

Imports System.IO
Imports Microsoft.Win32
Private Function ReadFontReg(ByVal strFontName As String) As String

        'read from the registry to get the font file name
        Dim regKey As RegistryKey
        Dim strAnswer As String = ""
        Dim strValues() As String

        regKey = Registry.LocalMachine.OpenSubKey("Software\Microsoft\Windows NT\CurrentVersion\Fonts", True)
        If Not regKey Is Nothing Then
            Try
                Dim i As Integer
                strValues = regKey.GetValueNames
                For i = 0 To strValues.Length - 1
                    If strValues(i) = strFontName Or strValues(i) = strFontName & " (TrueType)" Then
                        strAnswer = regKey.GetValue(strValues(i)).ToString
                        If Not File.Exists(strAnswer) Then
                            'add on the file path to the font folder
                            strAnswer = Environment.GetFolderPath(Environment.SpecialFolder.Fonts) & "\" & strAnswer
                        End If
                        Exit For
                    End If
                Next
            Catch ex As Exception

            Finally
                regKey.Close()
            End Try
        End If

        If strAnswer = "" Then
            'take a stab anyway. Might be lucky!
            Dim strSpecialFolderFonts As String
            Dim strFullPath As String

            strSpecialFolderFonts = Environment.GetFolderPath(Environment.SpecialFolder.Fonts) & "\"
            strFullPath = strSpecialFolderFonts & strFontName & ".ttf"
            If File.Exists(strFullPath) Then
                strAnswer = strFullPath
            Else
                strFullPath = strSpecialFolderFonts & strFontName & ".ttc"
                If File.Exists(strFullPath) Then
                    strAnswer = strFullPath
                End If
            End If
        End If
        Return strAnswer
    End Function