[原创]得到当前图形可用的fontfile和bigfontfile，请mccad等大侠指教
得到当前图形可用的fontfile和bigfontfile完成，请指教，以便改进。Dim myfile() As String
Dim strfontfile(), strbigfontfile() As String
Dim j, m, n As Integer
Sub pfont()
Dim spath() As String
Dim a As String
Dim i As Integer
m = 0
n = 0
j = 1
spath = Split(ThisDrawing.Application.Preferences.Files, ";")
For i = 0 To UBound(spath)
Findshxfile spath(i)
Next i
For j = 1 To UBound(strbigfontfile)
a = a & j & "-" & strbigfontfile(j) & " "
Next j
MsgBox a, , "当前可用的Bigfontfile"
For j = 1 To UBound(strfontfile)
a = a & j & "-" & strfontfile(j) & " "
Next j
MsgBox a, , "当前可用的Fontfile"
End Sub
Function Findshxfile(Path As String)
Dim strpath As String
Dim k As Integer
strpath = IIf(Right(Path, 1) = "\", Path, Path & "\")
ReDim Preserve myfile(j)
myfile(j) = Dir(strpath & "*.shx")
If myfile(j) <> "" Then fyn strpath & myfile(j)
Do While myfile(j) <> ""
j = j + 1
ReDim Preserve myfile(j)
myfile(j) = Dir
For k = 1 To j - 1
If myfile(j) = myfile(k) Then
j = j - 1
ReDim Preserve myfile(j)
GoTo 100
End If
Next k
If myfile(j) <> "" Then fyn strpath & myfile(j)
100:
Loop
End Function
Function fyn(s As String)
Dim b As String
Open s For Input As #1
Line Input #1, b
Close #1
If Mid(b, 12, 7) = "bigfont" Then
m = m + 1
ReDim Preserve strbigfontfile(m)
strbigfontfile(m) = myfile(j)
Else
n = n + 1
ReDim Preserve strfontfile(n)
strfontfile(n) = myfile(j)
End If
End Function 写成一个调用函数，这样方便使用：
Function GetFonts(ByRef FontFile As Variant, ByRef BigFontFile As Variant)
Dim strFontFile(), strBigFontFile() As String
Dim SearchPath() As String
Dim a As String
Dim i As Integer
Dim x As Integer
Dim y As Integer
Dim z As Boolean
Dim b As String
SearchPath = Split(ThisDrawing.Application.Preferences.Files, ";")
For i = 0 To UBound(SearchPath)
z = False
SearchPath(i) = IIf(Right(SearchPath(i), 1) = "\", SearchPath(i), SearchPath(i) & "\")
Do
If Not z Then
a = Dir(SearchPath(i) & "*.shx")
z = True
Else
a = Dir
End If
If a <> "" Then
a = SearchPath(i) & a
Open a For Input As #1
Line Input #1, b
Close #1
If Mid(b, 12, 7) = "bigfont" Then
x = x + 1
ReDim Preserve strBigFontFile(x)
strBigFontFile(x) = a
ElseIf Mid(b, 12, 7) = "unifont" Then
y = y + 1
ReDim Preserve strFontFile(y)
strFontFile(y) = a
End If
Else
Exit Do
End If
Loop
Next i
FontFile = strFontFile
BigFontFile = strBigFontFile
End Function
Sub GetShxFont()
Dim f As Variant
Dim bf As Variant
GetFonts f, bf
Dim i As Integer
Debug.Print "以下为普通字体："
For i = 0 To UBound(f)
Debug.Print f(i)
Next
Debug.Print "以下为大字体："
For i = 0 To UBound(bf)
Debug.Print bf(i)
Next
End Sub mccad高明！
多谢指道，我得慢慢研究。 to mccad：
你增加了对fontfile的判断，可以得到大部分的fontfile，但还有部分shape类型的文件未被列出，其特征为Mid(b, 12, 6) = "shapes"。
你在程序中保留了shx文件的路经，所以没有判断是有否重名的shx文件的语句。我想执行结果不保留shx文件的路经，所以程序中......但也总感觉我程序中使用的go to语句有点别脚，不知你有何高见？ 1.增加对形的判断，可以把
ElseIf Mid(b, 12, 7) = "unifont" Then
改为
ElseIf Mid(b, 12, 7) = "unifont" OrMid(b, 12, 6) = "shapes" Then
2.不保留路径，你可以增加一个变量保存带路径的文件名，然后不带路径的文件名用来保存于数组中，带路径的文件名用于文件的打开及查看文件是哪种字体。
3.而看看字体是否重复，得到字体名时，可先在已经保存的数组中看看是否有同名的名称，如果没有再增加，如果有则略过
4.一般不要使用Go To这样的语句，使用Do Loop来做再加上If..Then..Else..End If 来判断以退出循环Exit Do，这是我的做法，还有其它很多的方法可以做到。 Thank you.
页:
[1]