La fuente incrustada provoca un bloqueo
Tengo una aplicación WinForm. Estoy usando una fuente personalizada que está en mis recursos incrustados.
Funciona al principio, pero luego hace que el programa se bloquee después de un tiempo.
Usando el siguiente código como ejemplo, si sigo cambiando el tamaño del formulario, forzándolo a redibujarse constantemente, se bloqueará en unos pocos segundos. El mensaje que recibo es 'Error in 'Form1_Paint()'. Object is currently in use elsewhere.
'.
¿Qué estoy haciendo mal? ¿Cómo puedo evitar esto?
Tengo la fuente deaquí.
Gracias.
Imports System.Drawing.Text
Imports System.Runtime.InteropServices
Public Class Form1
Friend Harabara As Font
Private Sub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
LoadFonts()
End Sub
Private Sub Form1_Paint(ByVal sender As Object, ByVal e As System.Windows.Forms.PaintEventArgs) Handles Me.Paint
Try
e.Graphics.DrawString("This was drawn using the custom font 'Harabara'", Harabara, Brushes.Lime, 10.0F, 10.0F)
Catch ex As Exception
MsgBox("Error in Form1_Paint()'" & vbCrLf & ex.Message)
End Try
End Sub
Public Sub LoadFonts()
Try
Harabara = GetFontInstance(My.Resources.HarabaraHand, 24.0F, FontStyle.Italic)
Catch ex As Exception
MsgBox("Error in 'LoadFonts()'" & vbCrLf & ex.Message)
End Try
End Sub
Private Function GetFontInstance(ByVal data() As Byte, ByVal Size As Single, ByVal Style As FontStyle) As Font
Dim result As Font
Try
Dim pfc = New PrivateFontCollection
'LOAD MEMORY POINTER FOR FONT RESOURCE
Dim FontPtr As System.IntPtr = Marshal.AllocCoTaskMem(data.Length)
'COPY THE DATA TO THE MEMORY LOCATION
Marshal.Copy(data, 0, FontPtr, data.Length)
'LOAD THE MEMORY FONT INTO THE PRIVATE FONT COLLECTION
pfc.AddMemoryFont(FontPtr, data.Length)
'FREE UNSAFE MEMORY
Marshal.FreeCoTaskMem(FontPtr)
result = New Font(pfc.Families(0), Size, Style)
pfc.Families(0).Dispose()
pfc.Dispose()
Catch ex As Exception
'ERROR LOADING FONT. HANDLE EXCEPTION HERE
MsgBox("Error in 'GetFontInstance()'" & vbCrLf & ex.Message)
result = New Font(FontFamily.GenericMonospace, 8)
End Try
Return result
End Function
End Class