הנושאים החמים
א
אליהו פריד
אורח
- הוסף לסימניות
- #1
הייתי צריך לקטלג את הפונטים שלי במחשב
אז כתבתי סקריפט קטן
הנה הוא
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
אז כתבתי סקריפט קטן
הנה הוא
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
