字体形文件问题

gentellu

如何获取当前图形中所有字体的形支持文件及其路径？先谢了！

mccad

注意字体文件必须在Fonts字体目录下。而字体文件在文字样式中可得到。

gentellu

想实现此功能的本意是这样的，有时候经常拷图给别人，但别人可能没有此图相应的字体形支持文件，打开图形时会出现乱码或者是字位置不对，如果通过程序查找当前图形中所有字体的形支持文件及其路径，然后将所有字体的形支持文件及图形一起拷给别人就很方便了。


                                                 当然这种功能通过手动在CAD的支持目录里查找是可以实现的，但假如图形中的形支持文件较多时就非常不方便了。

gentellu

实现该功能的程序已写完，现将代码上传，欢迎大家试用并批评指正。 Sub getfontfilepath()

'返回图形支持文件目录
Dim supportfilepath As String
Dim supportfilepaths() As String
Dim i, j, m, n As Integer

supportfilepath = ThisDrawing.Application.preferences.Files.supportpath
Do
j = InStr(i + 1, supportfilepath, ";")
If j = 0 Then
n = Len(supportfilepath)
ReDim Preserve supportfilepaths(m)
supportfilepaths(m) = Right(supportfilepath, n - i)
Exit Do
Else
ReDim Preserve supportfilepaths(m)
supportfilepaths(m) = Mid(supportfilepath, i + 1, j - i - 1)
i = j
m = m + 1
End If
Loop

Dim element As AcadTextStyle
Dim fontfilepath As String
Dim fontfile As String
Dim fontfiles() As String
Dim bigfontfilepath As String
Dim bigfontfile As String
Dim bigfontfiles() As String
Dim k, l As Integer
'返回图形fontfile字体支持文件目录
n = 0
For Each element In ThisDrawing.TextStyles
fontfile = element.fontfile
For i = 0 To m
fontfilepath = supportfilepaths(i) + "\" + fontfile
fontfilepath = Dir(fontfilepath)
If fontfilepath <> "" Then
If k = 0 Then
ReDim Preserve fontfiles(k)
fontfiles(k) = supportfilepaths(i) + "\" + fontfile
k = k + 1
Else
ReDim Preserve fontfiles(k)
fontfiles(k) = supportfilepaths(i) + "\" + fontfile
For j = 0 To k - 1
If LCase(fontfiles(k)) = LCase(fontfiles(j)) Then
n = n + 1
End If
Next j
If n = 0 Then
k = k + 1
Else
n = 0
End If
End If
Exit For
End If
Next i
Next
'返回图形bigfontfile字体支持文件目录
For Each element In ThisDrawing.TextStyles
bigfontfile = element.bigfontfile
For i = 0 To m
bigfontfilepath = supportfilepaths(i) + "\" + bigfontfile
bigfontfilepath = Dir(bigfontfilepath)
If bigfontfilepath <> "" Then
If l = 0 Then
ReDim Preserve bigfontfiles(k)
bigfontfiles(k) = supportfilepaths(i) + "\" + bigfontfile
l = l + 1
Else
ReDim Preserve bigfontfiles(l)
bigfontfiles(l) = supportfilepaths(i) + "\" + bigfontfile
For j = 0 To l - 1
If LCase(bigfontfiles(l)) = LCase(bigfontfiles(j)) Then
n = n + 1
End If
Next j
If n = 0 Then
l = l + 1
Else
n = 0
End If
End If
Exit For
End If
Next i
Next
'显示图形中fontfile和bigfontfile字体支持文件目录
ThisDrawing.Utility.Prompt vbCrLf & "fontfile字体支持文件：" & vbCrLf
For i = 0 To k - 1
ThisDrawing.Utility.Prompt fontfiles(i) & vbCrLf
Next i
ThisDrawing.Utility.Prompt "bigfontfile字体支持文件："
For i = 0 To l - 1
ThisDrawing.Utility.Prompt bigfontfiles(i) & vbCrLf
Next i

End Sub

yj821005

不错的东西，不过还没来得及运行

gentellu

新增功能：将字体支持文件拷贝至指定文件夹。 Option Explicit
Function getfontfile(fontfilepath As String) As String

'返回图形fontfile字体支持文件目录下的字体支持文件
Dim fontfilepaths() As String
Dim i, j, m, n As Integer
Do
j = InStr(i + 1, fontfilepath, "\")
If j = 0 Then
n = Len(fontfilepath)
getfontfile = Right(fontfilepath, n - i)
Exit Do
Else
ReDim Preserve fontfilepaths(m)
fontfilepaths(m) = Mid(fontfilepath, i + 1, j - i - 1)
i = j
m = m + 1
End If
Loop

End Function
Sub getfontfilepath()

Dim supportfilepath As String
Dim supportfilepaths() As String
Dim i, j, m, n As Integer
'返回图形支持文件目录
supportfilepath = ThisDrawing.Application.preferences.Files.supportpath
Do
j = InStr(i + 1, supportfilepath, ";")
If j = 0 Then
n = Len(supportfilepath)
ReDim Preserve supportfilepaths(m)
supportfilepaths(m) = Right(supportfilepath, n - i)
Exit Do
Else
ReDim Preserve supportfilepaths(m)
supportfilepaths(m) = Mid(supportfilepath, i + 1, j - i - 1)
i = j
m = m + 1
End If
Loop

Dim element As AcadTextStyle
Dim fontfilepath As String
Dim fontfile As String
Dim fontfiles() As String
Dim bigfontfilepath As String
Dim bigfontfile As String
Dim bigfontfiles() As String
Dim k, l As Integer
'返回图形fontfile字体支持文件目录
n = 0
For Each element In ThisDrawing.TextStyles
fontfile = element.fontfile
For i = 0 To m
fontfilepath = supportfilepaths(i) + "\" + fontfile
fontfilepath = Dir(fontfilepath)
If fontfilepath <> "" Then
If k = 0 Then
ReDim Preserve fontfiles(k)
fontfiles(k) = supportfilepaths(i) + "\" + fontfile
k = k + 1
Else
ReDim Preserve fontfiles(k)
fontfiles(k) = supportfilepaths(i) + "\" + fontfile
For j = 0 To k - 1
If LCase(fontfiles(k)) = LCase(fontfiles(j)) Then
n = n + 1
End If
Next j
If n = 0 Then
k = k + 1
Else
n = 0
End If
End If
Exit For
End If
Next i
Next
'返回图形bigfontfile字体支持文件目录
For Each element In ThisDrawing.TextStyles
bigfontfile = element.bigfontfile
If bigfontfile <> "" Then
For i = 0 To m
bigfontfilepath = supportfilepaths(i) + "\" + bigfontfile
bigfontfilepath = Dir(bigfontfilepath)
If bigfontfilepath <> "" Then
If l = 0 Then
ReDim Preserve bigfontfiles(k)
bigfontfiles(k) = supportfilepaths(i) + "\" + bigfontfile
l = l + 1
Else
ReDim Preserve bigfontfiles(l)
bigfontfiles(l) = supportfilepaths(i) + "\" + bigfontfile
For j = 0 To l - 1
If LCase(bigfontfiles(l)) = LCase(bigfontfiles(j)) Then
n = n + 1
End If
Next j
If n = 0 Then
l = l + 1
Else
n = 0
End If
End If
Exit For
End If
Next i
End If
Next
'显示图形中fontfile和bigfontfile字体支持文件目录
ThisDrawing.Utility.Prompt vbCrLf & "fontfile字体支持文件：" & vbCrLf
For i = 0 To k - 1
ThisDrawing.Utility.Prompt fontfiles(i) & vbCrLf
Next i
ThisDrawing.Utility.Prompt "bigfontfile字体支持文件："
For i = 0 To l - 1
ThisDrawing.Utility.Prompt bigfontfiles(i) & vbCrLf
Next i

'选择是否将字体支持文件拷贝至指定文件夹
Dim kwordList As String
Dim destpath, destpath0 As String
On Error Resume Next
kwordList = "Yes No"
ThisDrawing.Utility.InitializeUserInput 1, kwordList
Dim returnString As String
returnString = ThisDrawing.Utility.GetKeyword("是否将字体支持文件拷贝至指定文件夹[Yes/No]：")
If returnString = "Yes" Then
destpath = InputBox("请输入目标文件夹！", "字体文件", ThisDrawing.Path)
destpath0 = destpath
destpath = Dir(destpath, vbDirectory)
If destpath <> "" Then
For i = 0 To k - 1
FileCopy fontfiles(i), destpath0 & "\" & getfontfile(fontfiles(i))
Next i
For i = 0 To l - 1
FileCopy bigfontfiles(i), destpath0 & "\" & getfontfile(bigfontfiles(i))
Next i
ThisDrawing.Utility.Prompt vbCrLf & "图形字体支持文件已拷贝至指定文件夹" & vbCrLf
Else
MsgBox "请输入正确的目标文件夹！"
Exit Sub
End If
Else
Exit Sub
End If

End Sub