modgetfont.bas

arcengine+vb开发原码

Attribute VB_Name = "modGetFont"


Option Explicit

Public pSG As IStyleGallery
Public pSGS As IStyleGalleryStorage
Public pOutFile As String
Public m_MarkerSym As ICharacterMarkerSymbol
Public m_NewFont As StdFont

Public ShowFontType
Public Const LF_FACESIZE = 32
Public Const LF_FULLFACESIZE = 64

Public Const NTM_REGULAR = &H40&
Public Const NTM_BOLD = &H20&
Public Const NTM_ITALIC = &H1&

Public Const PF_FIXED_PITCH = &H1
Public Const PF_VECTOR = &H2
Public Const PF_DEVICE = &H8
Public Const PF_TRUETYPE = &H4

Public Const ELF_VERSION = 0
Public Const ELF_CULTURE_LATIN = 0

Public Const RASTER_FONTTYPE = &H1
Public Const DEVICE_FONTTYPE = &H2
Public Const TRUETYPE_FONTTYPE = &H4

Type LOGFONT
  lgfntHeight As Long
  lgfntWidth As Long
  lgfntWeight As Long
  lgfntItalic As Byte
  lgfntUnderline As Byte
  lgfntStrikeOut As Byte
  lgfntOutPrecision As Byte
  lgfntClipPrecision As Byte
  lgfntQuality As Byte
  lgfntCharSet As Byte
  lgfntPitchAndFamily As Byte
  lgfntEscapement As Long
  lgfntOrientation As Long
  lgfntFaceName(LF_FACESIZE) As Byte
End Type

Type NEWTEXTMETRIC
  newtmHeight As Long
  newtmAscent As Long
  newtmDescent As Long
  newtmWeight As Long
  newtmOverhang As Long
  newtmAveCharWidth As Long
  newtmMaxCharWidth As Long
  newtmDigitizedAspectX As Long
  newtmDigitizedAspectY As Long
  newtmItalic As Byte
  newtmUnderlined As Byte
  newtmStruckOut As Byte
  newtmPitchAndFamily As Byte
  newtmCharSet As Byte
  newtmFirstChar As Byte
  newtmLastChar As Byte
  newtmDefaultChar As Byte
  newtmBreakChar As Byte
  newtmInternalLeading As Long
  newtmExternalLeading As Long
  newtmFlags As Long
  newtmSizeEM As Long
  newtmCellHeight As Long
  newtmAveWidth As Long
End Type

Declare Function EnumFontFamilies Lib _
  "gdi32" Alias "EnumFontFamiliesA" _
  (ByVal nhDC As Long, ByVal lpszFamily As String, _
   ByVal lpEnumFontFamProc As Long, lParam As Any) As Long

Declare Function GetDC Lib "USER32" _
   (ByVal hWnd As Long) As Long

Declare Function ReleaseDC Lib "USER32" _
   (ByVal hWnd As Long, ByVal nhDC As Long) As Long

Function EnumFontFamTypeProc(mLF As LOGFONT, _
                             mNTM As NEWTEXTMETRIC, _
                             ByVal FontType As Long, _
                             mObj As ComboBox) As Long
    
  ShowFontType = 4
  Dim FaceName As String
  If ShowFontType = FontType Then
    FaceName = StrConv(mLF.lgfntFaceName, vbUnicode)
    mObj.AddItem Left$(FaceName, InStr(FaceName, vbNullChar) - 1)
  End If
  EnumFontFamTypeProc = 1

End Function