字体形文件问题

gentellu 发表于 2005-3-2 23:44:00

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

mccad 发表于 2005-3-3 22:47:00

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

gentellu 发表于 2005-3-4 12:57:00

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

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

gentellu 发表于 2005-3-9 10:49:00

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

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 发表于 2005-3-9 11:51:00

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

gentellu 发表于 2005-3-9 16:54:00

新增功能：将字体支持文件拷贝至指定文件夹。

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("是否将字体支持文件拷贝至指定文件夹：") 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

页: [1]

明经CAD社区's Archiver

字体形文件问题