小吳 VBQA 程式設計討論

For intcount = 0 To Screen.FontCount - 1 If Mid(Screen.Fonts(intcount), 1, 1) ＜＞ "@" Then 　　.AddItem Screen.Fonts(intcount) 　　Next End With 這樣子就可以過濾掉不要的字型啦！ 我真是聰明..

你的作法會把不是 True Type 的字型也抓進來,例如 Courier 就不是True Type Font, 但是 Screen.Fonts 會包括此字型,要抓 True Type Font,需要利用 EnumFontFamilies 做 CallBack 來處理 True Type Font Form1 程式碼: '---------------------------------------- Option Explicit Private Sub Form_Load() Call ShowTrueTypeFont End Sub Private Sub ShowTrueTypeFont() Dim hDC As Long 　 　' 　 　'get the handle to the device context of the list to fill 　 hDC = GetDC(Form1.hWnd) 　 　 ShowFontType = TMPF_TRUETYPE 　 　'Add the fonts using the API and callback by calling 　'the EnumFontFamilies API, passing the AddressOf the 　'application-defined callback procedure EnumFontFamProc 　'and the list to fill 　 EnumFontFamilies hDC, vbNullString, AddressOf EnumFontFamTypeProc, List1 　 　'free the device context handle 　 ReleaseDC Form1.hWnd, hDC 　 End Sub '---------------------------------------------- Module1 程式碼 '------------------------------------------------- Option Explicit 'set in optFontType Public ShowFontType 'Font enumeration types Public Const LF_FACESIZE = 32 Public Const LF_FULLFACESIZE = 64 Type LOGFONT lfHeight As Long 　 lfWidth As Long 　 lfEscapement As Long 　 lfOrientation As Long 　 lfWeight As Long 　 lfItalic As Byte 　 lfUnderline As Byte 　 lfStrikeOut As Byte 　 lfCharSet As Byte 　 lfOutPrecision As Byte 　 lfClipPrecision As Byte 　 lfQuality As Byte 　 lfPitchAndFamily As Byte 　 lfFaceName(LF_FACESIZE) As Byte End Type Type NEWTEXTMETRIC tmHeight As Long 　 tmAscent As Long 　 tmDescent As Long 　 tmInternalLeading As Long 　 tmExternalLeading As Long 　 tmAveCharWidth As Long 　 tmMaxCharWidth As Long 　 tmWeight As Long 　 tmOverhang As Long 　 tmDigitizedAspectX As Long 　 tmDigitizedAspectY As Long 　 tmFirstChar As Byte 　 tmLastChar As Byte 　 tmDefaultChar As Byte 　 tmBreakChar As Byte 　 tmItalic As Byte 　 tmUnderlined As Byte 　 tmStruckOut As Byte 　 tmPitchAndFamily As Byte 　 tmCharSet As Byte 　 ntmFlags As Long 　 ntmSizeEM As Long 　 ntmCellHeight As Long 　 ntmAveWidth As Long End Type 'ntmFlags field flags Public Const NTM_REGULAR = &H40& Public Const NTM_BOLD = &H20& Public Const NTM_ITALIC = &H1& 'tmPitchAndFamily flags Public Const TMPF_FIXED_PITCH = &H1 Public Const TMPF_VECTOR = &H2 Public Const TMPF_DEVICE = &H8 Public Const TMPF_TRUETYPE = &H4 Public Const ELF_VERSION = 0 Public Const ELF_CULTURE_LATIN = 0 'EnumFonts Masks Public Const RASTER_FONTTYPE = &H1 Public Const DEVICE_FONTTYPE = &H2 Public Const TRUETYPE_FONTTYPE = &H4 Declare Function EnumFontFamilies Lib _ "gdi32" Alias "EnumFontFamiliesA" _ 　(ByVal hDC 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 hDC As Long) As Long Function EnumFontFamTypeProc(lpNLF As LOGFONT, _ lpNTM As NEWTEXTMETRIC, _ 　　　　　　　　　　　　　　 ByVal FontType As Long, _ 　　　　　　　　　　　　　　 lParam As ListBox) As Long Dim FaceName As String 　 　 If ShowFontType = FontType Then 　　　　 　　 'convert the returned string from Unicode to ANSI 　　　FaceName = StrConv(lpNLF.lfFaceName, vbUnicode) 　　　　 　　 'add the font to the list 　　　Debug.Print Left$(FaceName, InStr(FaceName, vbNullChar) - 1) 　 End If 　 　'return success to the call 　 EnumFontFamTypeProc = 1 End Function