yaodurant.drawing.gdifont.vb

Programming the .NET Compact Framework with vb 源代码

' YaoDurant.Drawing.GdiFont.vb - Supports the creation of 
' Win32 fonts.
'
' 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

Namespace YaoDurant.Drawing

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

      Public Const LF_FACESIZE = 32

      <DllImport("coredll.dll", CharSet:=CharSet.Unicode)> _
      Public Shared Function GetTextMetrics(ByVal hdc As IntPtr, _
      ByRef lptm As TEXTMETRIC) As Integer
      End Function

      <DllImport("coredll.dll", CharSet:=CharSet.Unicode)> _
      Public Shared Function GetTextExtentExPoint( _
      ByVal hdc As IntPtr, ByVal lpszStr As String, _
      ByVal cchString As Integer, ByVal nMaxExtent As Integer, _
      ByRef lpnFit() As Integer, ByRef alpDx() As Integer, _
      ByRef lpSize As System.Drawing.Size) As Integer
      End Function

      <DllImport("coredll.dll", CharSet:=CharSet.Unicode)> _
      Public Shared Function GetTextExtentExPoint( _
      ByVal hdc As IntPtr, ByVal lpszStr As String, _
      ByVal cchString As Integer, ByVal Res1 As Integer, _
      ByVal Res2 As Integer, ByVal Res3 As Integer, _
      ByRef lpSize As System.Drawing.Size) As Integer
      End Function

      '--------------------------------------------------------
      ' Create a Font for the display screen
      '--------------------------------------------------------
      Public Shared Function Create(ByVal strFace As String, _
      ByVal iSize As Integer, 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 hdc As IntPtr = GdiGraphics.GetDC(IntPtr.Zero)
         Dim hfont As IntPtr = Create(strFace, iSize, degrees, hdc)
         GdiGraphics.ReleaseDC(IntPtr.Zero, hdc)
         Return hfont
      End Function

      '--------------------------------------------------------
      ' Create a Font for a specific device
      '--------------------------------------------------------
      Public Shared Function Create(ByVal strFace As String, _
      ByVal iSize As Integer, ByVal degrees As Integer, _
      ByVal hdc As IntPtr) As IntPtr
         Dim cyDevice_Res As Integer = _
            GdiGraphics.GetDeviceCaps(hdc, CAPS.LOGPIXELSY)

         ' Calculate font height.
         Dim flHeight As Single = (CSng(iSize) * 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 = 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)

         Return CreateFontIndirect(iptrLogFont)
      End Function
   End Class


   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 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

End Namespace