Bigisayardaki font isimlerini listelemek..

[acolkesen1]

Merhaba arkadaşlar,
Bilgisayardaki font isimlerini listboxa alacak veya herhangi bir sayfaya listeleyecek kodlar konusunda yardıma ihtiyacım var. İlgilenen arkadaşlara teşekkür ederim.

 

[Necdet]

Merhaba,

http://www.j-walk.com/ss/excel/tips/tip79.htm listesinden aldığım kodları veriyorum.

Aşağıdaki kodları bir modüle kopyalayıp deneyiniz. A sütununa Fontları yazar.

Sub ShowInstalledFonts()
' [URL]http://www.j-walk.com/ss/excel/tips/tip79.htm[/URL]
    
    Dim fontlist
    Dim tempbar
    Dim i As Integer
    
    Set fontlist = Application.CommandBars("Formatting").FindControl(ID:=1728)
    
'   If Font control is missing, create a temp CommandBar
    If fontlist Is Nothing Then
        Set tempbar = Application.CommandBars.Add
        Set fontlist = tempbar.Controls.Add(ID:=1728)
    End If
    
'   Put the fonts into column A
    Range("A:A").ClearContents
    For i = 0 To fontlist.ListCount - 1
        Cells(i + 1, 1) = fontlist.List(i + 1)
    Next i
    
'   Delete temp CommandBar if it exists
    On Error Resume Next
    tempbar.Delete
End Sub

 

[acolkesen1]

Merhaba sayın Necdet Yeşertener,
İlginiz ve kodlar için teşekkür ederim. Esen kalın..

 

[Murat OSMA]

Alternatif...

Sub Yuklu_Fontlar()
Const Baslangic As Integer = 4
Dim ctrl As CommandBarControl, FontCmdBar As CommandBar, tFormula As String
Dim fontadi As String, i As Long, fontCount As Long, fontSize As Integer
    fontSize = 0
    fontSize = Application.InputBox("8 ile 30 Punto arasında bir değer giriniz.", _
         "Punto Seçimi", 12, , , , , 1)
    If fontSize = 0 Then Exit Sub
    If fontSize < 8 Then fontSize = 8
    If fontSize > 30 Then fontSize = 30
    Set ctrl = Application.CommandBars("Formatting").FindControl(ID:=1728)

    If ctrl Is Nothing Then
        Set FontCmdBar = Application.CommandBars.Add("Tempctrl", _
            msoBarFloating, False, True)
        Set ctrl = FontCmdBar.Controls.Add(ID:=1728)
    End If
    Application.ScreenUpdating = False
    fontCount = ctrl.ListCount
    Workbooks.Add

    For i = 0 To ctrl.ListCount - 1
        fontadi = ctrl.List(i + 1)
        Application.StatusBar = "Listing font " & _
            Format(i / (fontCount - 1), "0 %") & " " & _
            fontadi & "..."
        Cells(i + Baslangic, 1).Formula = fontadi
        With Cells(i + Baslangic, 2)
            tFormula = "abcdefghijklmnopqrstuvwxyz"
            If Application.International(xlCountrySetting) = 47 Then
                tFormula = tFormula & ""
            End If
            tFormula = tFormula & UCase(tFormula)
            tFormula = tFormula & "1234567890"
            .Formula = tFormula
            .Font.Name = fontadi
        End With
    Next i
    Application.StatusBar = False
    If Not FontCmdBar Is Nothing Then FontCmdBar.Delete
    Set FontCmdBar = Nothing
    Set ctrl = Nothing

    Columns(1).AutoFit
    With Range("A1")
        .Formula = "Yüklü Fontlar:"
        .Font.Bold = True
        .Font.Size = 14
    End With
    With Range("A3")
        .Formula = "Font Adı:"
        .Font.Bold = True
        .Font.Size = 12
    End With
    With Range("B3")
        .Formula = "Font Örneği:"
        .Font.Bold = True
        .Font.Size = 12
    End With
    With Range("B" & Baslangic & ":B" & _
        Baslangic + fontCount)
        .Font.Size = fontSize
    End With
    With Range("A" & Baslangic & ":B" & _
        Baslangic + fontCount)
        .VerticalAlignment = xlVAlignCenter
    End With
    Range("A4").Select
    ActiveWindow.FreezePanes = True
    Range("A2").Select
    ActiveWorkbook.Saved = True
End Sub

 

[acolkesen1]

Sayın Murat Osma'ya da teşekkürler..

 

[Murat OSMA]

Rica ederim, iyi günler...