在vba中如何获取所有字体!

rielzhou

怎样才能在窗体的复合框中显示系统和CAD中所有的字体啊??

谢谢各位!!!!

rielzhou

怎么没有人回答我呢??

真是伤心啊

难道就没有一位高手愿意帮忙吗?

mccad

需要得到字体所在的目录，读取所有文件名并进行判断。

rielzhou

具体怎么操作啊?

如何读取字体文体啊?

rielzhou

能不能给一段示例代码啊?

青青20

在autocad vba 二次开发教程第五章有一个类似的例子下面是部分)

Option Explicit

' 获得SHX字体
Public Function GetShxFont(ByVal bBigFont As Boolean) As Variant
    Dim strFontFileName() As String     ' 所有字体名称的数组
    Dim strFontPath() As String     ' AutoCAD的字体文件路径
   
    ' 获得所有的支持文件路径
    strFontPath = Split(ThisDrawing.Application.Preferences.Files, ";")
   
    ' 遍历所有的支持文件路径
    Dim i As Integer
    Dim bFirst As Boolean       ' 是否是第一次查找该文件夹
    Dim strFont As String       ' 字体文件名称
    Dim strTemp As String       ' 读取到的字体文件的一行
    Dim intCount As Integer     ' 字体数组的维数
    Dim strFontFile As String   ' 字体文件的位置
    intCount = -1
    For i = 0 To UBound(strFontPath)
        bFirst = True
        ' 确保最后一个字符是"\"
        strFontPath(i) = IIf(Right(strFontPath(i), 1) = "\", strFontPath(i), strFontPath(i) & "\")
       
        Do
            If bFirst Then
                strFont = Dir(strFontPath(i) & "*.shx")
                bFirst = False
            Else
                strFont = Dir
            End If
           
            If Len(strFont) <> 0 Then
                ' 打开字体文件
                strFontFile = strFontPath(i) & strFont
                Open strFontFile For Input As #1
                Line Input #1, strTemp
                Close #1
               
                ' 判断字体的类型
                If bBigFont Then
                    If Mid(strTemp, 12, 7) = "bigfont" Then
                        intCount = intCount + 1
                        ReDim Preserve strFontFileName(intCount)
                        strFontFileName(intCount) = strFont
                    End If
                Else
                    If Mid(strTemp, 12, 7) = "unifont" Or Mid(strTemp, 12, 6) = "shapes" Then
                        intCount = intCount + 1
                        ReDim Preserve strFontFileName(intCount)
                        strFontFileName(intCount) = strFont
                    End If
                End If
            Else
                Exit Do
            End If
        Loop
    Next i
   
    GetShxFont = strFontFileName
End Function

rielzhou

多谢楼上的大侠!!!

不过有个新的问题

我获取了字体文件之后只能得到字体文件的名称,而无法得到字体的名称

请大侠再指点迷津

感激不尽