Schriftarten/Fonts auslesen- eigenschaften
24.03.2007 19:25:00
lobby007
ich habe ein Makro das mir die Dateinamen und Schriftartnamen aller Fonts/Schriftartdateien ausliest:
Sub getFontName()
Dim objFS As FileSearch
Dim objSh As Worksheet
Dim strPath As String
Dim intIndex As Integer
On Error GoTo ErrExit
GetMoreSpeed
strPath = "c:\bjprinter" 'Pfad anpassen
Set objFS = Application.FileSearch
With objFS
.NewSearch
.LookIn = strPath
.FileName = "*.ttf"
'.SearchSubFolders = True
If .Execute > 0 Then
Set objSh = ThisWorkbook.Worksheets.Add(after:=ThisWorkbook.Sheets(Sheets.Count))
For intIndex = 1 To .FoundFiles.Count
objSh.Cells(intIndex, 1) = Dir(.FoundFiles(intIndex))
objSh.Cells(intIndex, 2) = TTFontName(.FoundFiles(intIndex))
Next
objSh.Columns.AutoFit
Set objSh = Nothing
End If
End With
ErrExit:
GetMoreSpeed 0
Set objFS = Nothing
End Sub
Private Sub GetMoreSpeed(Optional ByVal Modus As Integer = 1)
Static lngCalc As Long
With Application
If Modus = 1 Then
lngCalc = .Calculation
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
.Calculation = -4135
.Cursor = xlWait
Else
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
.Calculation = IIf(lngCalc 0, lngCalc, -4105)
.Cursor = xlDefault
End If
End With
End Sub
Ich brauche aber jetzt noch die weiteren Felder die bei einem solchen Fonts/Schriftart hinterlegt sind wie z.B. das Copyright etc. am besten alles was noch da ist und dann je Zeile ein Fonts.
Wer weiß Rat?
danke lobby007