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:
Sweet31 pe Simpatie
 | Femeie
25 ani
Bucuresti
cauta Barbat
25 - 47 ani |
|
|
TRaP
Moderator
Inregistrat: acum 6 ani
Postari: 748
|
|
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 5 ani |
|