Mrrrr's Forum (VIEW ONLY)
Un forum care ofera solutii pentru unele probleme legate in general de PC. Pe langa solutii, aici puteti gasi si alte lucruri interesante // A forum that offers solutions to some PC related issues. Besides these, here you can find more interesting stuff.
|
Lista Forumurilor Pe Tematici
|
Mrrrr's Forum (VIEW ONLY) | Reguli | Inregistrare | Login
POZE MRRRR'S FORUM (VIEW ONLY)
Nu sunteti logat.
|
Nou pe simpatie: alexxandra pe Simpatie
| Femeie 24 ani Timis cauta Barbat 24 - 57 ani |
|
TRaP
Moderator
Inregistrat: acum 6 ani
Postari: 787
|
|
Source:
It works very fast (the only slow component is the font iteration)
It won't find fonts not on your system, obviously, but if you are trying to prepare for transport something you wrote, and some assistant program has put Helvetica or MS Minchin in, you can find it
Sub FindAllFonts() Dim lWhichFont As Long, sTempName As String, sBuffer As String For lWhichFont = 1 To FontNames.Count sTempName = FontNames(lWhichFont) If FindThisFont(sTempName) Then sBuffer = sBuffer & "Found " & sTempName & vbCrLf Else If FindThisFont(Replace(sTempName, " ", "")) Then sBuffer = sBuffer & "Found " & sTempName & " *" & vbCrLf End If End If Next Documents.Add Selection.TypeText Text:=sBuffer End Sub
Function FindThisFont(sName As String) As Boolean Selection.HomeKey Unit:=wdStory Selection.Find.ClearFormatting With Selection.Find .Font.Name = sName .Forward = True .Format = True .Execute If .Found() Then FindThisFont = True Else FindThisFont = False End If End With End Function
|
People want to find fonts that aren't on their machines. But the other way is still too slow and involves looking for a lot of stuff not there. So here is an alternative that saves out as rtf, and processes the rtf header.
Sub FIndAllFonts2() Dim sOldName As String, sOldPath As String, sBuffer As String, sBuffer2 As String, sOut As String, sBit Dim lCounter As Long, lPos As Long, lPos2 As Long, lStopAt As Long Dim objPic As InlineShape, objShp As Shape ' rememer old name for reloading sOldName = ActiveDocument.Path 'delete image to make file out small For Each objPic In ActiveDocument.InlineShapes: objPic.Delete: Next For Each objShp In ActiveDocument.Shapes: objShp.Delete: Next ActiveDocument.SaveAs "tempout.rtf", wdFormatRTF sTempFile = ActiveDocument.Path ActiveDocument.Close lPos2 = 1 ' we only want the header, but we don't know how long the file is 'I am using a Mac, so filesystemobject not available ' if you end up having a huge header, make 2500 bigger lStopAt = 2500 Open sTempFile For Input As #1 Do While Not EOF(1) And lPos2 < lStopAt sBit = Input(1, #1) sBuffer = sBuffer & sBit lPos2 = lPos2 + 1 Loop Close #1 'delete temp file Kill sTempFile ' loop through header, fonts identified in the table as {\f1\ ' if you have more than 100 fonts, make this bigger ' not all numbers are used lStopAt = 100 For lCounter = 1 To lStopAt lPos = InStr(sBuffer, "{\f" & lCounter & "\") If lPos > 0 Then sBuffer = Mid(sBuffer, lPos) lPos = InStr(sBuffer, ";") sBuffer2 = Left(sBuffer, lPos - 1) 'this is where you would look for the alternate name if you want it lPos = InStr(sBuffer2, "{\*\falt") If lPos > 0 Then sBuffer2 = Left(sBuffer2, lPos - 1) sBuffer2 = Mid(sBuffer2, InStrRev(sBuffer2, " ") + 1) & " *" 'indicate it is the shorter ascii name Else sBuffer2 = Mid(sBuffer2, InStrRev(sBuffer2, "}") + 1) End If sOut = sOut & sBuffer2 & vbCrLf End If Next 'reopen old file Documents.Open sOldName Set newdoc = Documents.Add sOut = "Fonts in use in document " & sOldName & vbCrLf & sOut Selection.TypeText Text:=sOut End Sub
|
|
|
pus acum 6 ani |
|