قائمة بأسماء الخطوط المتاحة على جهازك برمجيا

[أبو آدم]

إخوتي الفضلاء

 

 

نحتاج أحياناً للتعرف على أنواع الخطوط الموجودة على جهاز كل منا ، للحصول على قائمة بأسماء الخطوط المتاحة على جهازك برمجيا مع مثال نصي لنوع الخط ضمن جدول في مستند يتم إنشاؤه حديثا ، نقدم اليوم هذا الحلّ البرمجي.

كيفية الاستخدام:

فتح مستند Word.

اضغط على Alt + F11 لفتح VBE.

إدراج وحدة نمطية. (Insert -> module)

لصق الكود التالي هناك في يمين الإطار 

 

 

Option Explicit

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:=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
 

 

إغلاق VBE  Alt+ Q  أو اضغط على X في الزاوية اليمنى العليا

حفظ الملف.

 

 

اختبار التعليمات البرمجية:

من Word، اضغط Alt + F8 لفتح مربع حوار الماكرو.

حدد   ListAllFonts

انقر فوق تشغيل.

 

والمرفق لتوضيح التطبيق

 

والله من وراء القصد وهو حسبي

 

..........

NA_ListInstalledFonts.zip

[أبا عمر]

جزاك_الله_خيرا

[رفعت يسري حامد]

ما شاء الله تبارك الله

الكود رائع جدًا

بارك الله فيك. وجعله الله في ميزان حسناتك.

[تومي محمد]

بارك الله فيك

[رفعت يسري حامد]

هل من الممكن معرفة الخطوط المستخدمة في مستند وورد وليس في الجهاز ككل؟؟؟ في مستند وورد

على حسب الكتابات الموجودة في المستند؟؟؟

===============================

أو

كود يسحب الخطوط المستخدمة في المستند

ثم وضعها في فولدر .

[أبو محمد عباس]

السلام عليكم

الاساتذة الكرام والاخوة الاعزاء جزاكم الله خيرا كود رائع وتم تطبيقه على  ملفي واستخرج جميع الخطوط

انا في الحقيقة عندي مشكله عند فتح الاكسل والوورد تظهر رسالة تفيد بانه ليس لدي اذونات كافية لتثبيت الخطوط كما ارفقت صورة للخطا وكذلك الخطوط الموجودة من خلال الكود الرائع

والمشكله حتى اتخطاها في كل مرة افتح فيها الوورد او الاكسل هي اضغط امر الغاء او تجاوز وهذا اتعبني ولا اعرف اين المشكلة وماهو الحل وبما انه وجدت موضوع يعنى بالخط اردت ان اطرحها هنا لايجاد الحل المناسب جزاكم الله خيرا

ودمتم في رعاية الله وحفظه

 

صورة الخطا عند البدء في فتح وورد او اكسل.rar

 

 

 

تم تعديل مارس 18, 2013 بواسطه عباس السماوي

[أبو محمد عباس]

السلام عليكم

الاخوة الاعزاء انا اعتذر لتكرار الموضوع بسبب ضعف النت

مع فائق احترامي وتقديري

 

تم تعديل مارس 18, 2013 بواسطه عباس السماوي

[حمادة عمر]

السلام عليكم

الاستاذ الرائع دوما / أبو آدم

 

بارك الله فيك

وفعلا كود رائع

جزاك الله خيرا