Populate combobox with Fonts

Hello,

How can i populate combobox with the fonts to use with autocad.

Best regards,
António Miranda

 

I'm going to assume you only want the fonts that are loaded into textstyles,
since they need to be attached to a style before they can be used to format
TEXT or MTEXT (I think). This lists them for the active drawing. Hope it
helps get you started. Just add it to a form with a wide listbox on it.

James

Private Sub UserForm_Click()
lst.ColumnCount = 3
Dim curStyle As AcadTextStyle

Dim typeFace As String, Bold As Boolean
Dim Italic As Boolean, charSet As Long
Dim PitchandFamily As Long

lst.Clear
lst.AddItem "STYLE"
lst.List(0, 1) = "TYPEFACE"
lst.List(0, 2) = "FONTFILE"
For Each curStyle In ThisDrawing.TextStyles
lst.AddItem curStyle.Name
curStyle.GetFont typeFace, Bold, Italic, charSet, PitchandFamily
lst.List(lst.ListCount - 1, 1) = typeFace
lst.List(lst.ListCount - 1, 2) = curStyle.fontFile

Next 'curStyle

End Sub

 

Hello,

It works, but i need to add into ListBox or ComboBox the Font Name, anyone can help me?


Best regards,
António miranda

 

Hi...

You need only fonts to AutoCAD or all the fonts of system windows?

I don't know if possible only fonts of AutoCAD, but yes with the fonts of system windows.

 

Thank's

 

Antonio,
From the little I know about this stuff, it looks like the Font Name is the
typeface. This is only for the fonts used in Autocad STYLES that are loaded
into the current drawing. I assumed this was what you wanted, since you
asked for the fonts "to use in Autocad."

Like SpeedCAD is asking, do you need a list of all of the fonts available in
Windows? I am not sure how to get those, but I agree with Speed that it
should not be too difficult. You would probably use a Windows API function.
But before you could use one of those fonts in AutoCAD, I believe you would
need to create a text style that uses the font.

Do you want all Windows fonts, or just the ones loaded into current AutoCAD
textstyles?

James

 

Hello,

To populate the WindowsFonts i've thsi Module, Work's vey fine:

'+++++++++++++++++++++

Option Explicit


'=============================================================================================================
'
' modFonts Module
' ---------------
'
' Created By : Kevin Wilson
' http://www.TheVBZone.com ( The VB Zone )
' http://www.TheVBZone.net ( The VB Zone .net )
'
' Last Update : May 2, 2000
'
' VB Versions : 5.0 / 6.0
'
' Requires : NOTHING
'
' Description : This module was created to easily list all the usable fontsin a ListBox, ComboBox, or
' multi-lined TextBox control.
'
' Example Use :
'
' FontsIntoListBox Me, List1, True, True
'
'=============================================================================================================
'
' LEGAL:
'
' You are free to use this code as long as you keep the above heading information intact and unchanged. Credit
' given where credit is due. Also, it is not required, but it would be appreciated if you would mention
' somewhere in your compiled program that that your program makes use of code written and distributed by
' Kevin Wilson (www.TheVBZone.com). Feel free to link to this code via your web site or articles.
'
' You may NOT take this code and pass it off as your own. You may NOT distribute this code on your own server
' or web site. You may NOT take code created by Kevin Wilson (www.TheVBZone.com) and use it to create products,
' utilities, or applications that directly compete with products, utilities, and applications created by Kevin
' Wilson, TheVBZone.com, or Wilson Media. You may NOT take this code and sell it for profit without first
' obtaining the written consent of the author Kevin Wilson.
'
' These conditions are subject to change at the discretion of the owner Kevin Wilson at any time without
' warning or notice. Copyright© by Kevin Wilson. All rights reserved..
'
'=============================================================================================================


Public 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(32) As Byte
End Type

Public 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

Public List_Text() As String
Public List_Count As Long

Public Declare Function GetDC Lib "USER32" (ByVal hWnd As Long) As Long
Public Declare Function ReleaseDC Lib "USER32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
Public Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
Public Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Public Declare Function GetDesktopWindow Lib "USER32" () As Long
Public Declare Function EnumFontFamiliesEx Lib "gdi32" Alias "EnumFontFamiliesExA" (ByVal hDC As Long, lpLogFont As LOGFONT, ByVal lpEnumFontProc As Long, lParam As Any, dw As Any) As Long

Public Function EnumFontFamProc(lpNLF As LOGFONT, lpntm As NEWTEXTMETRIC, ByVal FontType As Long, lParam As Long) As Long
On Error Resume Next

Dim fontName As String

' Convert the returned string to Unicode
fontName = StrConv(lpNLF.lfFaceName, vbUnicode)

' Add the font to the array
List_Count = List_Count + 1
ReDim Preserve List_Text(List_Count) As String
List_Text(List_Count) = Left(fontName, InStr(fontName, vbNullChar) - 1)

' Continue enumeration
EnumFontFamProc = 1

End Function

Public Function FontsIntoListBox(ByRef ListBoxToUse As ListBox, Optional ByVal SortList As Boolean = True, Optional ByVal SortAssending As Boolean = True)
On Error Resume Next

Dim MyCounter As Long
Dim TheDC As Long
Dim TempLOGFONT As LOGFONT

' Get the desktop's hDC so no form is needed to get a DC value
TheDC = GetDesktopDC
If TheDC = 0 Then
Exit Function
End If

' Clear the variables to hold the information
List_Count = 0
Erase List_Text
ListBoxToUse.Clear

' Put all the fonts into the variables
EnumFontFamiliesEx TheDC, TempLOGFONT, AddressOf EnumFontFamProc, ByVal 0&, ByVal 0&
DeleteDC TheDC
If List_Count = 0 Then
Exit Function
End If

' Sort the list
If SortList = True Then
SortListArray SortAssending
End If

' Put the fonts into the listbox
For MyCounter = 1 To List_Count
If Trim(List_Text(MyCounter)) <> "" Then
ListBoxToUse.AddItem Trim(List_Text(MyCounter))
End If
Next
ListBoxToUse.Selected(0) = True

End Function

Public Function FontsIntoComboBox(ByRef ComboBoxToUse As ComboBox, OptionalByVal SortList As Boolean = True, Optional ByVal SortAssending As Boolean = True)
On Error Resume Next

Dim MyCounter As Long
Dim TheDC As Long
Dim TempLOGFONT As LOGFONT

' Get the desktop's hDC so no form is needed to get a DC value
TheDC = GetDesktopDC
If TheDC = 0 Then
Exit Function
End If

' Clear the variables to hold the information
List_Count = 0
Erase List_Text
ComboBoxToUse.Clear

' Put all the fonts into the variables
EnumFontFamiliesEx TheDC, TempLOGFONT, AddressOf EnumFontFamProc, ByVal 0&, ByVal 0&
DeleteDC TheDC
If List_Count = 0 Then
Exit Function
End If

' Sort the list
If SortList = True Then
SortListArray SortAssending
End If

' Put the fonts into the listbox
For MyCounter = 1 To List_Count
If Trim(List_Text(MyCounter)) <> "" Then
ComboBoxToUse.AddItem Trim(List_Text(MyCounter))
End If
Next
ComboBoxToUse.Text = List_Text(0)

End Function

Public Function FontsIntoTextBox(ByRef TextBoxToUse As TextBox, Optional ByVal SortList As Boolean = True, Optional ByVal SortAssending As Boolean = True)
On Error Resume Next

Dim MyCounter As Long
Dim TheDC As Long
Dim TempLOGFONT As LOGFONT

' Check if TextBox is multiline
If TextBoxToUse.MultiLine = False Then
MsgBox "Can not put fonts into a TextBox control that has the MultiLineproperty set to FALSE.", vbOKOnly + vbExclamation, " Can't Put Fonts IntoNon-Multiline TextBox"
Exit Function
End If

' Get the desktop's hDC so no form is needed to get a DC value
TheDC = GetDesktopDC
If TheDC = 0 Then
Exit Function
End If

' Clear the variables to hold the information
List_Count = 0
Erase List_Text
TextBoxToUse.Text = ""

' Put all the fonts into the variables
EnumFontFamiliesEx TheDC, TempLOGFONT, AddressOf EnumFontFamProc, ByVal 0&, ByVal 0&
DeleteDC TheDC
If List_Count = 0 Then
Exit Function
End If

' Sort the list
If SortList = True Then
SortListArray SortAssending
End If

' Put the fonts into the listbox
For MyCounter = 1 To List_Count
If Trim(List_Text(MyCounter)) <> "" Then
If MyCounter <> List_Count Then
TextBoxToUse.Text = TextBoxToUse.Text & Trim(List_Text(MyCounter)) & vbCrLf
Else
TextBoxToUse.Text = TextBoxToUse.Text & Trim(List_Text(MyCounter))
End If
End If
Next

End Function

Private Function SortListArray(Optional ByVal SortAssending As Boolean = True)
On Error Resume Next

Dim MyCounter As Long
Dim MyCounter1 As Long
Dim TempList

If SortAssending = True Then
For MyCounter = UBound(List_Text) To 1 Step -1
For MyCounter1 = UBound(List_Text) To 0 Step -1
If LCase(List_Text(MyCounter)) > LCase(List_Text(MyCounter1)) Then
TempList = List_Text(MyCounter1)
List_Text(MyCounter1) = List_Text(MyCounter)
List_Text(MyCounter) = TempList
End If
Next
Next
Else
For MyCounter = 2 To UBound(List_Text)
For MyCounter1 = 1 To UBound(List_Text)
If LCase(List_Text(MyCounter)) > LCase(List_Text(MyCounter1)) Then
TempList = List_Text(MyCounter1)
List_Text(MyCounter1) = List_Text(MyCounter)
List_Text(MyCounter) = TempList
End If
Next
Next
End If

End Function

Private Function GetDesktopDC() As Long
On Error Resume Next

Dim hDskWnd As Long
Dim hTempDC As Long
Dim hMyDC As Long

' Get the handle for the desktop
hDskWnd = GetDesktopWindow
If hDskWnd = 0 Then
Exit Function
End If

' Create an hDC for the desktop
hTempDC = GetDC(hDskWnd)
If hTempDC = 0 Then
Exit Function
End If

' Create a compatible hDC for use
hMyDC = CreateCompatibleDC(hTempDC)
ReleaseDC hDskWnd, hTempDC

' Return the hDC of the desktop
If hMyDC = 0 Then
Exit Function
Else
GetDesktopDC = hMyDC
End If

End Function

'+++++++++++++++++++++++++++++++++++

I need now to populate the same Combobox with the AcadFonts.

Best regards,
António Miranda