ایجاد فهرست قلم سند

Question

Word به شما این امکان را می دهد که از فونت های نصب شده روی سیستمی که استفاده می کنید استفاده کنید. فونت ها در ویندوز نصب می شوند، به طوری که نه تنها برای Word، بلکه برای همه برنامه های نصب شده روی سیستم شما در دسترس هستند.

هنگامی که در حال ایجاد یک سند در سیستم خود هستید، به راحتی می توانید بدانید که از چه فونت هایی استفاده می شود - لیست فونت ها محدود به فونت های موجود در سیستم است. با این حال، اگر سندی را از شخص دیگری دریافت می‌کنید، سیستم شخص دیگر ممکن است فونت‌های متفاوتی نسبت به شما نصب کرده باشد.

اگر می‌خواهید فهرستی از فونت‌های مورد استفاده در یک سند ایجاد کنید (برخلاف فهرستی از فونت‌های موجود در یک سیستم)، چند انتخاب دارید. اول از همه، می‌توانید سند Word را در یک ویرایشگر متن باز کنید و به قسمت‌هایی از سند که معمولاً در Word نمی‌بینید نگاه کنید. در نزدیکی انتهای فایل باید فهرستی از فونت‌های استفاده شده در سند را ببینید. با این حال، اگر این کار را انجام دهید، باید بسیار مراقب باشید تا زمانی که سند Word در ویرایشگر متن شما باز است، هیچ تغییری در سند ورد ایجاد نکنید. انجام این کار به راحتی باعث می شود که سند دیگر در Word قابل استفاده نباشد.

یک راه حل مبتنی بر Word این است که به سادگی به هر کاراکتر در یک سند نگاه کنید و بررسی کنید که از چه فونتی برای قالب بندی کاراکتر استفاده شده است. رویکرد کاراکتر به کاراکتر ضروری است زیرا هر کاراکتر می‌تواند با فونت متفاوتی قالب‌بندی شود و VBA به شما اجازه دسترسی به مجموعه فونت‌ها را در رابطه با خود سند نمی‌دهد - به نظر می‌رسد که چنین مجموعه‌ای نگهداری نمی‌شود. امن ترین (و کندترین) روش این است که به سادگی از هر کاراکتر عبور کرده و لیست خود را ایجاد کنید. ماکرو VBA زیر این کار را انجام می دهد:

Public Sub ListFontsInDoc()
    Dim FontList(199) As String
    Dim FontCount As Integer
    Dim FontName As String
    Dim J As Integer, K As Integer, L As Integer
    Dim X As Long, Y As Long
    Dim FoundFont As Boolean
    Dim rngChar As Range
    Dim strFontList As String

    FontCount = 0
    X = ActiveDocument.Characters.Count
    Y = 0
    " For-Next loop through every character
    For Each rngChar In ActiveDocument.Characters
        Y = Y + 1
        FontName = rngChar.Font.Name
        StatusBar = Y & ":" & X
        " check if font used for this char already in list
        FoundFont = False
        For J = 1 To FontCount
           If FontList(J) = FontName Then FoundFont = True
        Next J
        If Not FoundFont Then
            FontCount = FontCount + 1
            FontList(FontCount) = FontName
        End If
    Next rngChar

    " sort the list
    StatusBar = "Sorting Font List"
    For J = 1 To FontCount - 1
        L = J
        For K = J + 1 To FontCount
            If FontList(L) > FontList(K) Then L = K
        Next K
        If J <> L Then
            FontName = FontList(J)
            FontList(J) = FontList(L)
            FontList(L) = FontName
        End If
    Next J

    StatusBar = ""
    " put in new document
    Documents.Add
    Selection.TypeText Text:="There are " & _
      FontCount & " fonts used in the document, as follows:"
    Selection.TypeParagraph
    Selection.TypeParagraph
    For J = 1 To FontCount
        Selection.TypeText Text:=FontList(J)
        Selection.TypeParagraph
    Next J
End Sub

بدیهی است که هرچه سند شما طولانی‌تر باشد، تکمیل ماکرو بیشتر طول می‌کشد. (من ماکرو را روی یک سند 1100 صفحه ای اجرا کردم و تقریباً 46 دقیقه طول کشید. در یک سند 5 صفحه ای کمتر از یک دقیقه طول کشید.) پس از اتمام، ماکرو سند جدیدی ایجاد می کند که حاوی لیست مرتب شده ای از فونت های استفاده شده است.