|
|
发表于 2006-12-26 14:11:00
|
显示全部楼层
在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
|
|
置顶卡
