yaodurant.drawing.createfont.vb

Programming the .NET Compact Framework with vb 源代码

' YaoDurant.Drawing.CreateFont.vb - Wrapper for creating a 
' Win32 font
'
' Code from _Programming the .NET Compact Framework with C#_
' and _Programming the .NET Compact Framework with VB_
' (c) Copyright 2002-2003 Paul Yao and David Durant. 
' All rights reserved.

Imports System
Imports System.Runtime.InteropServices
Imports YaoDurant.Win32

'
' VB namespace note: VB programs have a default root namespace
' which is the same as the project name. To establish a separate
' namespace that is not part of the root namespace, like the
' YaoDurant.Drawing namespace here, remove the definition of
' the namespace in the project properties dialog box.
Namespace YaoDurant.Drawing
Public Class GdiFont

   '
   ' Text metric helper function & data structure.
   '
   <DllImport("coredll.dll")> _
   Public Shared Function GetTextMetrics(ByVal hdc As IntPtr, _
   ByRef lptm As TEXTMETRIC) As Integer
   End Function

   Public Structure TEXTMETRIC
      Public tmHeight As Integer
      Public tmAscent As Integer
      Public tmDescent As Integer
      Public tmInternalLeading As Integer
      Public tmExternalLeading As Integer
      Public tmAveCharWidth As Integer
      Public tmMaxCharWidth As Integer
      Public tmWeight As Integer
      Public tmOverhang As Integer
      Public tmDigitizedAspectX As Integer
      Public tmDigitizedAspectY As Integer
      Public tmFirstChar As Byte
      Public tmLastChar As Byte
      Public tmDefaultChar As Byte
      Public tmBreakChar As Byte
      Public tmItalic As Byte
      Public tmUnderlined As Byte
      Public tmStruckOut As Byte
      Public tmPitchAndFamily As Byte
      Public tmCharSet As Byte
   End Structure

   <DllImport("coredll.dll")> _
   Public Shared Function CreateFontIndirect( _
   ByVal lplf As IntPtr) As IntPtr
   End Function

   ' The logical font structure -- minus the face name.
   Public Structure LOGFONT
      Public lfHeight As Integer
      Public lfWidth As Integer
      Public lfEscapement As Integer
      Public lfOrientation As Integer
      Public lfWeight As Integer
      Public lfItalic As Byte
      Public lfUnderline As Byte
      Public lfStrikeOut As Byte
      Public lfCharSet As Byte
      Public lfOutPrecision As Byte
      Public lfClipPrecision As Byte
      Public lfQuality As Byte
      Public lfPitchAndFamily As Byte
      '         public TCHAR [] lfFaceName;
   End Structure

   Public Const LF_FACESIZE As Integer = 32

   '--------------------------------------------------------
   '--------------------------------------------------------
   Public Shared Function Create( _
   ByVal hdcDevice As IntPtr, _
   ByVal strFace As String, _
   ByVal sinSize As Single, _
   ByVal degrees As Integer) As IntPtr
      ' Calculate font height based on this ratio:
      ' 
      '    Height in Pixels       Desired Point Size
      '  -------------------  =   ------------------
      '   Device Resolution              72
      '
      ' (72 point = approx. 1 inch.)
      '
      ' Which results in the following formula:
      '
      ' Height = (Desired_Pt * Device_Res) / 72
      '
      Dim hFont As IntPtr

      Dim cyDevice_Res As Integer
      cyDevice_Res = GdiGraphics.GetDeviceCaps( _
         hdcDevice, GdiGraphics.LOGPIXELSY)

      ' Calculate font height.
      Dim flHeight As Single
      flHeight = (sinSize * CSng(cyDevice_Res)) / 72.0F
      Dim iHeight As Integer = CInt(flHeight + 0.5)

      ' Set height negative to request 'Em-Height' (versus
      ' 'character-cell height' for positive size)
      iHeight = iHeight * (-1)

      ' Allocate managed code logfont structure
      Dim logfont As logfont = New logfont

      logfont.lfHeight = iHeight
      logfont.lfWidth = 0
      logfont.lfEscapement = degrees * 10
      logfont.lfOrientation = 0
      logfont.lfWeight = 0
      logfont.lfItalic = 0
      logfont.lfUnderline = 0
      logfont.lfStrikeOut = 0
      logfont.lfCharSet = 0
      logfont.lfOutPrecision = 0
      logfont.lfClipPrecision = 0
      logfont.lfQuality = 0
      logfont.lfPitchAndFamily = 0

      ' Allocate unmanaged code logfont structure.
      Dim cbLogFont As Integer = Marshal.SizeOf(logfont)
      Dim cbMem As Integer = cbLogFont + LF_FACESIZE
      Dim iptrLogFont As IntPtr = NativeHeap.LocalAlloc(NativeHeap.LPTR, cbMem)
      If iptrLogFont.Equals(IntPtr.Zero) Then
         Return IntPtr.Zero
      End If

      ' Copy managed structure to unmanaged buffer
      Marshal.StructureToPtr(logfont, iptrLogFont, False)

      ' Set pointer to end of structure
      Dim ipFaceDest As IntPtr
      ipFaceDest = New IntPtr(iptrLogFont.ToInt32() + cbLogFont)

      ' Copy string to a character array.
      Dim achFace() As Char = strFace.ToCharArray()
      Dim cch As Integer = strFace.Length

      ' Copy facename to unmanaged buffer
      Marshal.Copy(achFace, 0, ipFaceDest, cch)

      hFont = CreateFontIndirect(iptrLogFont)

      NativeHeap.LocalFree(iptrLogFont)

      Return hFont
   End Function

End Class

End Namespace