[原创]得到当前图形可用的fontfile和bigfontfile，请mccad等大侠指教

iwzw

得到当前图形可用的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

mccad

写成一个调用函数，这样方便使用：　

2. Function GetFonts(ByRef FontFile As Variant, ByRef BigFontFile As Variant)
   
3.     Dim strFontFile(), strBigFontFile() As String
   
4.     Dim SearchPath() As String
   
5.     Dim a As String
   
6.     Dim i As Integer
   
7.     Dim x As Integer
   
8.     Dim y As Integer
   
9.     Dim z As Boolean
   
10.     Dim b As String
    
11.    
    
12.     SearchPath = Split(ThisDrawing.Application.Preferences.Files, ";")
    
13.     For i = 0 To UBound(SearchPath)
    
14.     z = False
    
15.         SearchPath(i) = IIf(Right(SearchPath(i), 1) = "", SearchPath(i), SearchPath(i) & "")
    
16.         Do
    
17.             If Not z Then
    
18.                 a = Dir(SearchPath(i) & "*.shx")
    
19.                 z = True
    
20.             Else
    
21.                 a = Dir
    
22.             End If
    
23.             If a <> "" Then
    
24.                 a = SearchPath(i) & a
    
25.                 Open a For Input As #1
    
26.                 Line Input #1, b
    
27.                 Close #1
    
28.                 If Mid(b, 12, 7) = "bigfont" Then
    
29.                     x = x + 1
    
30.                     ReDim Preserve strBigFontFile(x)
    
31.                     strBigFontFile(x) = a
    
32.                 ElseIf Mid(b, 12, 7) = "unifont" Then
    
33.                     y = y + 1
    
34.                     ReDim Preserve strFontFile(y)
    
35.                     strFontFile(y) = a
    
36.                 End If
    
37.             Else
    
38.                 Exit Do
    
39.             End If
    
40.         Loop
    
41.     Next i
    
42.     FontFile = strFontFile
    
43.     BigFontFile = strBigFontFile
    
44. End Function
    
45. 
    
46. Sub GetShxFont()
    
47.     Dim f As Variant
    
48.     Dim bf As Variant
    
49.     GetFonts f, bf
    
50.     Dim i As Integer
    
51.     Debug.Print "以下为普通字体："
    
52.     For i = 0 To UBound(f)
    
53.         Debug.Print f(i)
    
54.     Next
    
55.     Debug.Print "以下为大字体："
    
56.     For i = 0 To UBound(bf)
    
57.         Debug.Print bf(i)
    
58.     Next
    
59. End Sub

Function GetFonts(ByRef FontFile As Variant, ByRef BigFontFile As Variant)<br />     Dim strFontFile(), strBigFontFile() As String<br />     Dim SearchPath() As String<br />     Dim a As String<br />     Dim i As Integer<br />     Dim x As Integer<br />     Dim y As Integer<br />     Dim z As Boolean<br />     Dim b As String<br />     <br />     SearchPath = Split(ThisDrawing.Application.Preferences.Files, ";")<br />     For i = 0 To UBound(SearchPath)<br />     z = False<br />         SearchPath(i) = IIf(Right(SearchPath(i), 1) = "", SearchPath(i), SearchPath(i) & "")<br />         Do<br />             If Not z Then<br />                 a = Dir(SearchPath(i) & "*.shx")<br />                 z = True<br />             Else<br />                 a = Dir<br />             End If<br />             If a <> "" Then<br />                 a = SearchPath(i) & a<br />                 Open a For Input As #1<br />                 Line Input #1, b<br />                 Close #1<br />                 If Mid(b, 12, 7) = "bigfont" Then<br />                     x = x + 1<br />                     ReDim Preserve strBigFontFile(x)<br />                     strBigFontFile(x) = a<br />                 ElseIf Mid(b, 12, 7) = "unifont" Then<br />                     y = y + 1<br />                     ReDim Preserve strFontFile(y)<br />                     strFontFile(y) = a<br />                 End If<br />             Else<br />                 Exit Do<br />             End If<br />         Loop<br />     Next i<br />     FontFile = strFontFile<br />     BigFontFile = strBigFontFile<br /> End Function<br /> <br /> Sub GetShxFont()<br />     Dim f As Variant<br />     Dim bf As Variant<br />     GetFonts f, bf<br />     Dim i As Integer<br />     Debug.Print "以下为普通字体："<br />     For i = 0 To UBound(f)<br />         Debug.Print f(i)<br />     Next<br />     Debug.Print "以下为大字体："<br />     For i = 0 To UBound(bf)<br />         Debug.Print bf(i)<br />     Next<br /> End Sub

iwzw

mccad高明！
多谢指道，我得慢慢研究。

iwzw

to mccad：
你增加了对fontfile的判断，可以得到大部分的fontfile，但还有部分shape类型的文件未被列出，其特征为Mid(b, 12, 6) = "shapes"。
你在程序中保留了shx文件的路经，所以没有判断是有否重名的shx文件的语句。我想执行结果不保留shx文件的路经，所以程序中......但也总感觉我程序中使用的go to语句有点别脚，不知你有何高见？

mccad

1.增加对形的判断，可以把
ElseIf Mid(b, 12, 7) = "unifont" Then
改为
ElseIf Mid(b, 12, 7) = "unifont" Or  Mid(b, 12, 6) = "shapes" Then

2.不保留路径，你可以增加一个变量保存带路径的文件名，然后不带路径的文件名用来保存于数组中，带路径的文件名用于文件的打开及查看文件是哪种字体。

3.而看看字体是否重复，得到字体名时，可先在已经保存的数组中看看是否有同名的名称，如果没有再增加，如果有则略过

4.一般不要使用Go To这样的语句，使用Do Loop来做再加上If..Then..Else..End If 来判断以退出循环Exit Do，这是我的做法，还有其它很多的方法可以做到。

iwzw

Thank you.