• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Bigisayardaki font isimlerini listelemek..

Katılım
5 Aralık 2007
Mesajlar
635
Excel Vers. ve Dili
Office 2007
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.
 
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.

Kod:
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
 
Merhaba sayın Necdet Yeşertener,
İlginiz ve kodlar için teşekkür ederim. Esen kalın..
 
Alternatif...

Kod:
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
 
Rica ederim, iyi günler...
 
Geri
Üst