Font Teil -1

Sub SchriftartenLesen()
Dim CBC As CommandBarControl
Dim iCnt As Integer, strTxt As String
Dim iCnt2 As Integer
iCnt = 1
Cells.Select
Selection.ClearContents
Selection.Delete
Application.ScreenUpdating = False
strTxt = InputBox("Testtext:", "")
If strTxt = "" Then Exit Sub
Set CBC = Application.CommandBars.FindControl(ID:=1728)
For iCnt = 1 To CBC.ListCount
With Cells(iCnt, 1)
.Value = strTxt
.Font.Name = CBC.List(iCnt)
End With
Cells(iCnt, 2) = CBC.List(iCnt)
Next iCnt
Cells.Select
With Selection.Interior
.ColorIndex = 2
.Pattern = xlSolid
End With
Range("A1").Select
Columns("A:B").AutoFit
Application.ScreenUpdating = True
iCnt2 = 3
Application.ScreenUpdating = False
strTxt = InputBox("Testtext:", "")
If strTxt = "" Then Exit Sub
Set CBC = Application.CommandBars.FindControl(ID:=1728)
For iCnt2 = 1 To CBC.ListCount
With Cells(iCnt2, 3)
.Value = strTxt
.Font.Name = CBC.List(iCnt2)
.Font.Bold = True
End With
Cells(iCnt2, 4) = CBC.List(iCnt2)
Next iCnt2
Cells.Select
With Selection.Interior
.ColorIndex = 2
.Pattern = xlSolid
End With
Range("A1").Select
Columns("C:D").AutoFit
Application.ScreenUpdating = True
Range("C:C,A:A").Select
Range("A1,A:A,C:C").Select
With Selection.Font
.Size = 16
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
End Sub