小编点评

```vba Dim winFontsdir As String Dim temp As Variant, i As Long, fontDir As String winFontsdir = VBA.Environ("windir") & "\\\Fonts\" If winFontsdir <> vbNullString Then Dim shxfl As String shxfl = VBA.dir(winFontsdir) While shxfl <> vbNullString Debug.Print winfontsdir & shxfl shxfl = dir() Wend End If temp = VBA.Split(Application.Preferences.Files.SupportPath, "\;") For i = LBound(temp) To UBound(temp) If temp(i) Like "*\\fonts" Then fontDir = temp(i) & "\\\" Exit For End If Next If fontDir <> vbNullString Then Dim shxfl As String shxfl = VBA.dir(fontDir) While shxfl <> vbNullString Debug.Print fontDir & shxfl shxfl = dir() Wend End If ``` **使用步骤：** 1. 将代码复制到 cad 中的代码编辑器中。 2. 设置 Preferences -> Files -> Support Path。 3. 按下“保存”。 4. 在代码中运行代码。 **注意：** * 代码中使用 `vbNullString` 用于表示空字符串。 * `VBA.dir()` 函数返回一个包含文件名和路径的字符串的数组。 * `Like` 运算符用于检查文件名是否包含 `*` 或 `.`。

正文

cad中的可用字体样式

 

 

获取windows标准字体

Dim winFontsdir As String
    
    winFontsdir = VBA.Environ("windir") & "\Fonts\"
    If winFontsdir <> vbNullString Then
        Dim shxfl As String
        shxfl = VBA.dir(winFontsdir)
        While shxfl <> vbNullString
            Debug.Print winFontsdir & shxfl
            shxfl = dir()
        Wend
    End If

获取cad字体样式名称

 

Dim temp As Variant, i As Long, fontDir As String
    temp = VBA.Split(Application.Preferences.Files.SupportPath, ";")
    For i = LBound(temp) To UBound(temp)
        If temp(i) Like "*\fonts" Then
            fontDir = temp(i) & "\"
            Exit For
        End If
    Next
    If fontDir <> vbNullString Then
        Dim shxfl As String
        shxfl = VBA.dir(fontDir)
        While shxfl <> vbNullString
            Debug.Print fontDir & shxfl
            shxfl = dir()
        Wend
    End If