tüm yazı tipleri ile sayfaya yazma

[peleryn]

Merhabalar;

A1 hücresine yazacağım bir kelimeyi diyelim "Asker" olsun.a2 hücresinden başlayarak bilgisayarımda bulunan a dan z ye tüm yazı tipleri ile aşağı doğru yazdırabilir miyim?

 

[Ömer]

Merhaba,

Module kopyalayıp çalıştırınız.

Sub FontaGoreListele()
 
    Dim Font, sat As Integer
    
    Set Font = Application.CommandBars.FindControl(ID:=1728)
    
    Application.ScreenUpdating = False
    
    Range("A2:A" & Rows.Count).Clear
    
    On Error GoTo atla
    sat = 2
    Do Until Err <> 0
        With Cells(sat, "A")
            .Value = Range("A1").Value
            .Font.Name = Font.List(sat - 1)
            sat = sat + 1
        End With
    Loop
    
    Application.ScreenUpdating = True
    Exit Sub
atla:
 
End Sub

.

 

[mancubus]

google'dan bulduklarım.

excel için

Sub ShowInstalledFonts()
'http://www.exceltip.com/st/Display_all_installed_fonts_(Excel)_using_VBA_in_Microsoft_Excel/512.html

Const StartRow As Integer = 4
Dim FontNamesCtrl As CommandBarControl, FontCmdBar As CommandBar, tFormula As String
Dim fontName As String, i As Long, fontCount As Long, fontSize As Integer
    fontSize = 0
    fontSize = Application.InputBox("Enter Sample Font Size Between 8 And 30", _
         "Select Sample Font Size", 12, , , , , 1)
    If fontSize = 0 Then Exit Sub
    If fontSize < 8 Then fontSize = 8
    If fontSize > 30 Then fontSize = 30
    Set FontNamesCtrl = Application.CommandBars("Formatting").FindControl(ID:=1728)
    ' If Font control is missing, create a temp CommandBar
    If FontNamesCtrl Is Nothing Then
        Set FontCmdBar = Application.CommandBars.Add("TempFontNamesCtrl", _
            msoBarFloating, False, True)
        Set FontNamesCtrl = FontCmdBar.Controls.Add(ID:=1728)
    End If
    Application.ScreenUpdating = False
    fontCount = FontNamesCtrl.ListCount
    ' list font names in column A and font example in column B
    For i = 0 To FontNamesCtrl.ListCount - 1
        fontName = FontNamesCtrl.List(i + 1)
        Application.StatusBar = "Listing font " & _
            Format(i / (fontCount - 1), "0 %") & " " & _
            fontName & "..."
        Cells(i + StartRow, 1).Formula = fontName
        With Cells(i + StartRow, 2)
            tFormula = "abcdefghijklmnopqrstuvwxyz"
            If Application.International(xlCountrySetting) = 47 Then
                tFormula = tFormula & "æøå"
            End If
            tFormula = tFormula & UCase(tFormula)
            tFormula = tFormula & "1234567890"
            .Formula = tFormula
            .Font.Name = fontName
        End With
    Next i
    Application.StatusBar = False
    If Not FontCmdBar Is Nothing Then FontCmdBar.Delete
    Set FontCmdBar = Nothing
    Set FontNamesCtrl = Nothing
    ' add heading
    Columns(1).AutoFit
    With Range("A1")
        .Formula = "Installed fonts:"
        .Font.Bold = True
        .Font.Size = 14
    End With
    With Range("A3")
        .Formula = "Font Name:"
        .Font.Bold = True
        .Font.Size = 12
    End With
    With Range("B3")
        .Formula = "Font Example:"
        .Font.Bold = True
        .Font.Size = 12
    End With
    With Range("B" & StartRow & ":B" & _
        StartRow + fontCount)
        .Font.Size = fontSize
    End With
    With Range("A" & StartRow & ":B" & _
        StartRow + fontCount)
        .VerticalAlignment = xlVAlignCenter
    End With
    Range("A4").Select
    ActiveWindow.FreezePanes = True
    Range("A2").Select
End Sub

 

[mancubus]

word için

Sub ListAllFonts()
'http://www.vbaexpress.com/kb/getarticle.php?kb_id=487

Dim oDoc    As Word.Document
Dim oTable  As Word.Table
Dim iCnt    As Long
 
 If MsgBox("Do you wish to build a list?" & vbCr & _
           "Building a list on older systems this may take a while" & vbCr & _
           vbCr & "Screen may appear frozen" & vbCr & _
           "Please wait for the list to complete", _
           vbQuestion + vbYesNo, "Built Font list") = vbYes Then
                      
 Application.ScreenUpdating = False
 
 'Create new doc to list font's
 Set oDoc = Application.Documents.Add
 
 'Create table of 2 columns and as many rows as there are fontnames
 Set oTable = oDoc.Tables.Add(Range:=Selection.Range, _
                              NumRows:=Application.FontNames.Count + 1, _
                              NumColumns:=2)
    With oTable
    'Create table header
        With .Cell(1, 1).Range
            .Font.Name = "Arial"
            .Font.Bold = True
            .InsertAfter "Font Name"
        End With
        
        With .Cell(1, 2).Range
            .Font.Name = "Arial"
            .Font.Bold = True
            .InsertAfter "Font Example"
        End With
        
        'Loop through Fontnames
        For iCnt = 1 To Application.FontNames.Count
            'Add Fontname to cell
            With .Cell(iCnt + 1, 1).Range
                .Font.Name = "Arial"
                .Font.Size = 10
                .InsertAfter Application.FontNames(iCnt)
            End With
            
            'Set Font in Cell to Fontname and insert example text
            With .Cell(iCnt + 1, 2).Range
                .Font.Name = Application.FontNames(iCnt)
                .Font.Size = 10
                .InsertAfter "ABCDEFG 1234567890 hijklmnop"
            End With
        Next iCnt
        
        'No borders and sort table Ascending
        .Borders.Enable = False
        .Sort SortOrder:=wdSortOrderAscending
    End With
 End If
End Sub

 

[peleryn]

Ömer Hocam,sayın mancubus yardımlarınızla sorunumu hallettim çok teşekkür ederim.

 

[mancubus]

rica ederim.

yazanların eline sağlık.

ben çok basit kodlar için bile google'a bakarım.
hazır bir şey var ise yazmak için harcanacak zamandan tasarruf ettirir.

kodların kaynağını da kod'un içinde belirtmek ve sürekli orada tutmak ta kadirşinaslık olur.