这是早些年从俄罗斯网站上看到的一个收集字体插件，语言是用VBscript写的，能用，但个别字体不能收集完成，现在Adobe也在illustrator中加入了收集字体打包功能，所以这个也很少用啦。
使用方法：
下好插件，或把下面的代码存入到本地侯后缀名改为.vbs，然后把.ai文件往.vbs文件上面拖动即可，运行完后，插件会自动创建一个名为 Fonts_ai的文件夹，文档内使用过的字体会打包进这个文件夹里。
' lsd, 2012
option explicit
Dim WshShell, objFSO, regg, txtFile, x
Dim strLine, strLinePfb, objArgs, ext, i
Dim reg
Dim strArr()
Dim regEx
Dim strRemoveAllPattern
Set regEx = New RegExp
With regEx
.Global = True
.IgnoreCase = True
End With
Set WshShell = WScript.CreateObject("WScript.Shell")
WshShell.run "regedit /a C:\Windows\Temp\ftemp.txt ""HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Fonts""",,true
Set objFSO = Createobject("Scripting.FileSystemObject")
Set regg = CreateObject("WScript.Shell")
Set objArgs = WScript.Arguments
ext=objFSO.GetExtensionName(objArgs(0))
If (InStr(LCase(ext), "ai") = 0) AND (InStr(LCase(ext), "eps") = 0) Then Wscript.Quit
ext=objFSO.GetFile(objArgs(0))
Set txtFile = objFSO.OpenTextFile(ext,1)
i=0
Do While Not txtFile.AtEndOfStream
x=txtFile.Readline
If InStr(x, "fontFileName") Then
ReDim Preserve strArr(i)
strRemoveAllPattern = "<(?:(?:stFnt:fontFileName>)|/(?:stFnt:fontFileName>))"
strLine=Onlyfonts(regEx,x)
strRemoveAllPattern = ";(?:.*)"
strLine=Onlyfonts(regEx,strLine)
strRemoveAllPattern = "^\s+|\s+$"
strArr(i)=Onlyfonts(regEx,strLine)
i=i+1
End If
Loop
txtFile.Close
ext=objFSO.GetParentFolderName(ext)
If objFSO.FolderExists(ext & "\Fonts_ai")=0 Then
ext=objFSO.CreateFolder (ext & "\Fonts_ai")
Else
Set ext = objFSO.GetFolder(ext & "\Fonts_ai")
end if
For i = 0 To UBound(strArr)
On Error Resume Next
If InStr(LCase(strArr(i)), "pfb") Then
regEx.Pattern = "(?:pfb)"
strLine = regEx.Replace(strArr(i),"pfm")
objFSO.CopyFile "C:\PSFONTS\PFM\"& strLine , ext&"\", true
End If
objFSO.CopyFile "c:\windows\fonts\"& strArr(i) , ext&"\", true
If Err.Number<>0 Then
Set txtFile = objFSO.OpenTextFile("C:\Windows\Temp\ftemp.txt",1)
Do While Not txtFile.AtEndOfStream
x=txtFile.Readline
If InStr(x, strArr(i)) Then
strRemoveAllPattern = "(?:.*)=""|""$"
strLine=Onlyfonts(regEx,x)
regEx.Pattern = "(\\{2})"
strLine = regEx.Replace(strLine,"\")
End If
Loop
txtFile.Close
objFSO.CopyFile strLine , ext&"\", true
Err.Clear
End If
Next
objFSO.DeleteFile("C:\Windows\Temp\ftemp.txt")
Function Onlyfonts(regEx,strInput)
On Error Resume Next
regEx.Pattern = strRemoveAllPattern
Onlyfonts = regEx.Replace(strInput,vbNullString)
End Function
