Schriftartennamen auslesen aus Verzeichnis2

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Private Sub Fonts_lesen() Dim i As Integer With Application.FileSearch .LookIn = "D:\fonts" .SearchSubFolders = True .Filename = "*.TTF" .Execute For i = 1 To .FoundFiles.Count Cells(i + 1, 1).Value = Dir(.FoundFiles(i)) Next i End With End Sub

Hallo Lars!
Probier mal.

' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Private Declare Function CreateScalableFontResource Lib "gdi32" _
  Alias "CreateScalableFontResourceA" (ByVal fHidden As Long, _
  ByVal lpszResourceFile As String, ByVal lpszFontFile As String, _
  ByVal lpszCurrentPath As String) As Long

Public Function TTFontName(FileName As String) As String
'Source=http://www.aboutvb.de/khw/artikel/khwttfontname.htm
Dim nFNr As Integer
Dim nContents As String
Dim nTempFile As String
Dim nPos As Long

nTempFile = Environ("TEMP") & "\temp.fot"

If CreateScalableFontResource(1, nTempFile, FileName, _
  vbNullString) Then
  nFNr = FreeFile
  On Error GoTo TTFontName_Error
  Open nTempFile For Binary Access Read As #nFNr
  nContents = Space(LOF(nFNr))
  Get #nFNr, , nContents
  Close #nFNr
  Kill nTempFile
  nPos = InStr(nContents, "FONTRES:") + 8
  If nPos Then
    TTFontName = Mid(nContents, nPos, InStr(nPos, nContents, _
      vbNullChar) - nPos)
  End If
End If
Exit Function

TTFontName_Error:
Resume
End Function

Sub getFontName()
Dim objFS As FileSearch
Dim objSh As Worksheet
Dim strPath As String
Dim intIndex As Integer

strPath = "C:\windows\fonts" '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

Set objFS = Nothing

End Sub

Gruß Sepp

Hallo Lars!
Dann mal mit Fehlerbehandlung.

' **********************************************************************
' Modul: Modul3 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Private Declare Function CreateScalableFontResource Lib "gdi32" _
  Alias "CreateScalableFontResourceA" (ByVal fHidden As Long, _
  ByVal lpszResourceFile As String, ByVal lpszFontFile As String, _
  ByVal lpszCurrentPath As String) As Long

Public Function TTFontName(FileName As String) As String
'Source=http://www.aboutvb.de/khw/artikel/khwttfontname.htm
Dim nFNr As Integer
Dim nContents As String
Dim nTempFile As String
Dim nPos As Long

nTempFile = Environ("TEMP") & "\temp.fot"

If CreateScalableFontResource(1, nTempFile, FileName, _
  vbNullString) Then
  nFNr = FreeFile
  On Error GoTo TTFontName_Error
  Open nTempFile For Binary Access Read As #nFNr
  nContents = Space(LOF(nFNr))
  Get #nFNr, , nContents
  Close #nFNr
  Kill nTempFile
  nPos = InStr(nContents, "FONTRES:") + 8
  If nPos Then
    TTFontName = Mid(nContents, nPos, InStr(nPos, nContents, _
      vbNullChar) - nPos)
  End If
Else
  TTFontName = "File Error! Can´t Read Fontname"
  Err.Clear
End If

Exit Function

TTFontName_Error:
TTFontName = "File Error! Can´t Read Fontname"

Resume
End Function

Sub getFontName()
Dim objFS As FileSearch
Dim objSh As Worksheet
Dim strPath As String
Dim intIndex As Integer

On Error GoTo ErrExit
GetMoreSpeed

strPath = "F:\" '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

Gruß Sepp

Beliebteste Forumthreads (12 Monate)

Schriftartennamen auslesen aus Verzeichnis2

11 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

11
Beiträge zum Forumthread

Beiträge zu diesem Forumthread