Schriftarten in Excel Datei

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

' ********************************************************************** ' Modul: Modul1 Typ: Allgemeines Modul ' ********************************************************************** Option Explicit Sub Unzip1() Dim objShell As Object, objItem As Object Dim strPath As String, strFile As String Dim lngRow As Long strPath = "E:\Forum\" ' Ordner mit den ZIP-Dateien - ANPASSEN! If Right(strPath, 1) <> "\" Then strPath = strPath & "\" strFile = Dir(strPath & "*.zip", vbNormal) Set objShell = CreateObject("Shell.Application") Do While strFile <> "" For Each objItem In objShell.Namespace(strPath & strFile).items lngRow = lngRow + 1 Cells(lngRow, 1) = strFile Cells(lngRow, 2) = objItem.Name Next strFile = Dir Loop Set objShell = Nothing End Sub

Hallo Sigrid,
das automatische Installieren der Schriftarten ist nur bedingt möglich.
Erstens brauchst du Administratoren-rechte und auch sonst gibt es einige Hürden.
Da das doch ein Eingriff ins System ist, würde ich die folgenden Weg vorschlagen.
Der folgende Code erstellt auf dem Desktop einen Ordner namens 'Fonts' und entpackt alle Schriftarten in diesen Ordner.
Nachdem alle Schriftarten im Ordner sind, öffnest du diesen, markierst alle Dateien und wählst im Kontextmenü 'Installieren', damit werden alle Schriftarten im System registriert. Die dabei evtl. erscheinenden Dialoge kann man nicht unterdrücken und erscheinen auch, wenn man per Code die Installation durchführen würde, deshalb hat es keinen Sinn. Es gibt zwar Möglichkeiten, allerdings erfordern die entweder Zusatzprogramme oder man muss die Registry manipulieren und auch dann ist nicht garantiert, dass es problemlos läuft.

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

Option Explicit

Private Declare PtrSafe Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal lpPath As String) As Long

Sub extractFontsFromZip()
Dim objShell As Object, objItem As Object
Dim strPath As String, strFile As String
Dim varTempPath As Variant, lngC As Long

On Error GoTo ErrorHandler

With Application.FileDialog(msoFileDialogFolderPicker)
  .InitialFileName = "E:\Forum\"
  .Title = "Ordnerauswahl - ZIP-Dateien mit Schriftart"
  .ButtonName = "Extrahieren"
  .InitialView = msoFileDialogViewList
  If .Show = -1 Then
    strPath = .SelectedItems(1)
    If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
  End If
End With

If Len(strPath) Then
  varTempPath = Environ("USERPROFILE") & "\Desktop\Fonts\"
  
  Call MakeSureDirectoryPathExists(varTempPath)
  
  Set objShell = CreateObject("Shell.Application")
  
  strFile = Dir(strPath & "*.zip", vbNormal)
  
  Do While strFile <> ""
    For Each objItem In objShell.Namespace(strPath & strFile).Items
      Select Case LCase(Right(objItem.Name, 3))
        Case "ttf", "ttc", "fon", "otf"
          lngC = lngC + 1
          objShell.Namespace(varTempPath).CopyHere _
            objShell.Namespace(strPath & strFile).Items.Item(objItem.Name)
          Exit For
        Case Else
      End Select
    Next
    strFile = Dir
  Loop
End If

If lngC > 0 Then
  If MsgBox("Es wurden " & CStr(lngC) & " Schriftarten in den Ordner " & varTempPath & _
    " kopiert!" & vbLf & vbLf & "Solldieser Ordner geöffnet werden?", vbInformation + _
    vbYesNo, "Schriftarten entpacken") = vbYes Then
    Shell "C:\Windows\explorer.exe /e, " & varTempPath, vbNormalFocus
  End If
End If
ErrorHandler:

If Err.Number <> 0 Then
  MsgBox "Fehler in Modul1" & vbLf & vbLf & "Prozedur:" & vbTab & "listFontFromZip" & vbLf & _
    "Nummer:" & vbTab & Err.Number & vbLf & "Meldung:" & vbTab & Err.Description & vbLf & _
    IIf(Erl, "Zeile:" & vbTab & Erl, ""), vbExclamation, "Fehler!"
  Err.Clear
End If

Set objShell = Nothing
End Sub

Gruß Sepp

' ********************************************************************** ' Modul: Modul1 Typ: Allgemeines Modul ' ********************************************************************** Option Explicit #If VBA7 Then Private Declare PtrSafe Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal lpPath As String) As Long #Else Private Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal lpPath As String) As Long #End If Sub extractFontsFromZip() Dim objShell As Object, objItem As Object Dim strPath As String, strFile As String Dim varTempPath As Variant, lngC As Long On Error GoTo ErrorHandler With Application.FileDialog(msoFileDialogFolderPicker) .InitialFileName = "E:\Forum\" .Title = "Ordnerauswahl - ZIP-Dateien mit Schriftart" .ButtonName = "Extrahieren" .InitialView = msoFileDialogViewList If .Show = -1 Then strPath = .SelectedItems(1) If Right(strPath, 1) <> "\" Then strPath = strPath & "\" End If End With If Len(strPath) Then varTempPath = Environ("USERPROFILE") & "\Desktop\Fonts\" Call MakeSureDirectoryPathExists(varTempPath) Set objShell = CreateObject("Shell.Application") strFile = Dir(strPath & "*.zip", vbNormal) Do While strFile <> "" For Each objItem In objShell.Namespace(strPath & strFile).Items Select Case LCase(Right(objItem.Name, 3)) Case "ttf", "ttc", "fon", "otf" lngC = lngC + 1 objShell.Namespace(varTempPath).CopyHere _ objShell.Namespace(strPath & strFile).Items.Item(objItem.Name) Exit For Case Else End Select Next strFile = Dir Loop End If If lngC > 0 Then If MsgBox("Es wurden " & CStr(lngC) & " Schriftarten in den Ordner " & varTempPath & _ " kopiert!" & vbLf & vbLf & "Solldieser Ordner geöffnet werden?", vbInformation + _ vbYesNo, "Schriftarten entpacken") = vbYes Then Shell "C:\Windows\explorer.exe /e, " & varTempPath, vbNormalFocus End If End If ErrorHandler: If Err.Number <> 0 Then MsgBox "Fehler in Modul1" & vbLf & vbLf & "Prozedur:" & vbTab & "listFontFromZip" & vbLf & _ "Nummer:" & vbTab & Err.Number & vbLf & "Meldung:" & vbTab & Err.Description & vbLf & _ IIf(Erl, "Zeile:" & vbTab & Erl, ""), vbExclamation, "Fehler!" Err.Clear End If Set objShell = Nothing End Sub

Beliebteste Forumthreads (12 Monate)

19 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

19
Beiträge zum Forumthread

Beiträge zu diesem Forumthread