פונט קטלוג פונטים

[ayle]

אני מעלה פה מאקרו לקטלוג פונטים, מתוך הפורום לתוכנה וחומרה, התודות הם לטיפוגרף כותב ההודעה.
הנה המאקרו, יש להעתיק ולהדביק בוורד בעורך המאקרו:
Sub ListAllFonts()
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:=4)
With oTable
'Create table header
With .Cell(1, 1).Range
.Font.Name = "OGENBLACK"
.Font.Bold = True
.InsertAfter "שם הפונט"
End With

With .Cell(1, 2).Range
.Font.Name = "OGENBLACK"
.Font.Bold = True
.InsertAfter "תצוגת הפונט"
End With

With .Cell(1, 3).Range
.Font.Name = "OGENBLACK"
.Font.Bold = True
.InsertAfter "טקסט קצר"
End With

With .Cell(1, 4).Range
.Font.Name = "OGENBLACK"
.Font.Bold = True
.InsertAfter "שם הפונט"
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 "אבגדהוזחטיכלמנסעפצקרשת כםןףץ 1234567890 (?!)"
End With

'Set Font in Cell to Fontname and insert example text
With .Cell(iCnt + 1, 3).Range
.Font.Name = Application.FontNames(iCnt)
.Font.Size = 16
.InsertAfter "כך נפץ התרסק על גוזל קטן שדחף את צבי למים"
End With


'Set Font in Cell to Fontname and insert example text
With .Cell(iCnt + 1, 4).Range
.Font.Name = oTable.Cell(iCnt + 1, 3).Range.Font.Name
.Font.Size = 10
If .Font.Name = "Tahoma" Then oTable.Cell(iCnt + 1, 4).Row.Delete


.InsertAfter "פונט עברי"
End With

Next iCnt

'No borders and sort table Ascending
.Borders.Enable = False
.Sort SortOrder:=wdSortOrderAscending
End With
End If
End Sub
בהצלחה

 

[RCpro]

מה הסיבה שהעלית את זה פתאום?

למה לא שמת קישור, אולי יש שם עוד דברים באשכול שיכולים לעזור.

 

[חיטובים]

יש גם MainType ו-Xfonter שעושות קטלוגים אוטומטית ותומכות בעברית

 

[RCpro]

אתם גוררים אותי להגיב...
http://www.prog.co.il/showthread.php?t=5665

 

[חיטובים]

באמת שכחתי את ה FontExpert היא מעולה
גם המייןטייפ טובה מאוד

 

[ונתנו10]

Dim oDoc As Word.Document

בעצם לא קשור, אבל אולי אפשר לשאול כאן.
מה זה ה: DIM בויזואל בייסיק?
מה בעצם אני מרוויח מהקיצור הזה?

 

[zevUP]

השתמשתי בזה וזה מאוד נפלא אבל זה יוצר רק קיטלוג לפונטים עבריים, איך עושים את אותו הדבר לקיטלוג הפונטים באנגלית??

 

[RCpro]

במקום אבגדהו וכו' תכתוב ABC וכו'...