ماکروی ورد برای درج سربرگ و پابرگ فارسی + شماره صفحه فارسی (فقط با یک کلیک!) 🖱️

آموزش تحقیق و پژوهش نکات و ترفندهای پژوهش
1

:sparkles: مقدمه

آیا از تنظیم دستی سربرگ و پابرگ در مقاله‌ها و گزارش‌های خود خسته شده‌اید؟ :tired_face:

نگارش متون علمی و رسمی به زبان فارسی، همیشه با چالش‌های قالب‌بندی همراه است. یکی از وقت‌گیرترین این چالش‌ها، تنظیم دقیق سربرگ و پابرگ همراه با تاریخ و شماره صفحه است. اینجا یک راه‌حل حرفه‌ای و کاملاً خودکار داریم: ماکروی پیشرفته VBA که در تمام بخش‌های سند، تنها با یک کلیک، سربرگ و پابرگ شما را استاندارد می‌کند، تاریخ را به‌صورت شمسی دقیق درج می‌کند و شماره صفحات را با اعداد فارسی واقعی نمایش می‌دهد. :rocket:

این ابزار به‌خصوص برای دانشجویان، پژوهشگران، ویراستاران و ناشرانی که با اسناد فارسی سروکار دارند، یک کمک‌یار فوق‌العاده است.

نگارش متون علمی و رسمی به زبان فارسی، همیشه با چالش‌های قالب‌بندی همراه است. یکی از وقت‌گیرترین این چالش‌ها، تنظیم دقیق سربرگ و پابرگ به همراه شماره‌گذاری صفحات است. در این آموزش، ما به شما یک ماکروی پیشرفته و کاملاً خودکار معرفی می‌کنیم که تنها با یک کلیک، همه این کارها را به سرعت و دقت انجام می‌دهد.

[!tip] :pushpin: آشنایی با ماکرو و نحوه ساخت و اجرای آن
اگر با مفهوم ماکرو و نحوه ساخت و اجرای آن آشنا نیستید، پیشنهاد می‌کنیم پیش از ادامه این مطلب، نگاهی به «ماکرو در ورد: خودکارسازی هوشمند کارهای تکراری!» بیندازید. آنجا به زبان ساده با ماکرو، روش‌های ایجاد و اجرای آن و نکات امنیتی آشنا می‌شوید.

ویژگی‌های اصلی این ماکرو :bullseye:

این ماکرو که با زبان VBA در محیط Microsoft Word طراحی شده، قابلیت‌های کلیدی زیر را به سند شما اضافه می‌کند:

  • سربرگ استاندارد: شامل عنوان مقاله و نام نویسنده، با فونت و چینش استاندارد فارسی.

  • پابرگ استاندارد: شامل تاریخ روز (شمسی دقیق بر پایه الگوریتم جلالی) و شماره صفحه با اعداد فارسی یونیکد.

  • اجرای خودکار روی تمام بخش‌ها: حتی در اسناد چندبخشی یا دارای سربرگ و پابرگ متفاوت.

  • تنظیم فاصله استاندارد: فاصله دقیق سربرگ و پابرگ از لبه صفحه.

  • پشتیبانی از فونت‌های فارسی و انگلیسی: به‌صورت پیش‌فرض فونت «B Nazanin» برای فارسی و «Times New Roman» برای انگلیسی استفاده می‌شود.

  • حذف شماره صفحه‌های قبلی: از تکرار یا به‌هم‌ریختگی پابرگ جلوگیری می‌کند.

  • هشدار هوشمند برای صفحات زوج/فرد متفاوت: کاربر را از ساختار سند آگاه می‌کند.

  • اجرا تنها با یک کلیک: بدون نیاز به هیچ تنظیمات دستی. :computer_mouse:

کد کامل ماکرو :hammer_and_wrench:

برای استفاده از این ماکرو، کافی است مراحل زیر را دنبال کنید:

  1. تب Developer را در ورد فعال کنید (اگر فعال نیست).
  2. روی گزینه Macros کلیک کرده، یک نام مناسب برای ماکرو وارد کنید و دکمه Create را بزنید.
  3. کد زیر را به‌صورت کامل در محیط ویرایشگر VBA کپی و جای‌گذاری کنید:

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

Sub InsertHeaderFooterInAllSections()
    ' تعريف متغيرها
    Dim docTitle As String
    Dim authorName As String
    Dim sec As Section
    Dim warningShown As Boolean
    Dim solarDate As String

    warningShown = False

    ' دريافت اطلاعات از کاربر با متن فارسي
    Dim prompt1 As String, title1 As String
    Dim prompt2 As String, title2 As String


    prompt1 = ChrW(1604) & ChrW(1591) & ChrW(1601) & ChrW(1575) & ChrW(1593) & ChrW(1606) & ChrW(1608) & ChrW(1575) & ChrW(1606) & ChrW(32)
    prompt1 = prompt1 & ChrW(1605) & ChrW(1602) & ChrW(1575) & ChrW(1604) & ChrW(1607) & ChrW(32) & ChrW(1585) & ChrW(1575) & ChrW(32) & ChrW(1608) & ChrW(1575) & ChrW(1585) & ChrW(1583) & ChrW(32)
    prompt1 = prompt1 & ChrW(1705) & ChrW(1606) & ChrW(1740) & ChrW(1583) & ChrW(58)

    title1 = ChrW(1608) & ChrW(1585) & ChrW(1608) & ChrW(1583) & ChrW(32) & ChrW(1593) & ChrW(1606) & ChrW(1608) & ChrW(1575) & ChrW(1606)


    prompt2 = ChrW(1604) & ChrW(1591) & ChrW(1601) & ChrW(1575) & ChrW(32) & ChrW(1606) & ChrW(1575) & ChrW(1605) & ChrW(32) & ChrW(1606) & ChrW(1608) & ChrW(1740) & ChrW(1587) & ChrW(1606) & ChrW(1583) & ChrW(1607) & ChrW(32)
    prompt2 = prompt2 & ChrW(1585) & ChrW(1575) & ChrW(32) & ChrW(1608) & ChrW(1575) & ChrW(1585) & ChrW(1583) & ChrW(32) & ChrW(1705) & ChrW(1606) & ChrW(1740) & ChrW(1583) & ChrW(58)

    title2 = ChrW(1608) & ChrW(1585) & ChrW(1608) & ChrW(1583) & ChrW(32) & ChrW(1606) & ChrW(1575) & ChrW(1605) & ChrW(32) & ChrW(1606) & ChrW(1608) & ChrW(1740) & ChrW(1587) & ChrW(1606) & ChrW(1583) & ChrW(1607)

    docTitle = InputBox(prompt1, title1)
    authorName = InputBox(prompt2, title2)
    
    If docTitle = "" Or authorName = "" Then
        Dim errorMsg As String
        Dim errorTitle As String

        errorMsg = ChrW(1593) & ChrW(1606) & ChrW(1608) & ChrW(1575) & ChrW(1606) & ChrW(32) & ChrW(1605) & ChrW(1602) & ChrW(1575) & ChrW(1604) & ChrW(1607) & ChrW(32)
        errorMsg = errorMsg & ChrW(1608) & ChrW(32) & ChrW(1606) & ChrW(1575) & ChrW(1605) & ChrW(32) & ChrW(1606) & ChrW(1608) & ChrW(1740) & ChrW(1587) & ChrW(1606) & ChrW(1583) & ChrW(1607) & ChrW(32)
        errorMsg = errorMsg & ChrW(1606) & ChrW(1605) & ChrW(1740) & ChrW(32) & ChrW(1578) & ChrW(1608) & ChrW(1575) & ChrW(1606) & ChrW(1583) & ChrW(32)
        errorMsg = errorMsg & ChrW(1582) & ChrW(1575) & ChrW(1604) & ChrW(1740) & ChrW(32) & ChrW(1576) & ChrW(1575) & ChrW(1588) & ChrW(1583) & ChrW(33)

        errorTitle = ChrW(1582) & ChrW(1591) & ChrW(1575)

        MsgBox errorMsg, vbExclamation, errorTitle
        Exit Sub
    End If

    ' تبديل تاريخ ميلادي به شمسي
    solarDate = ConvertToShamsi(Date)

    ' اعمال تنظيمات براي همه بخش‌ها
    For Each sec In ActiveDocument.Sections
        ' تنظيم فاصله سربرگ و پابرگ
        With sec.PageSetup
            .HeaderDistance = CentimetersToPoints(1.5)
            .FooterDistance = CentimetersToPoints(1.5)
        End With

        ' هشدار صفحات زوج/فرد (فقط يک‌بار)
        If ActiveDocument.PageSetup.OddAndEvenPagesHeaderFooter And Not warningShown Then
            Dim warningText As String
            Dim warningTitle As String

            warningText = ChrW(1578) & ChrW(1608) & ChrW(1580) & ChrW(1607) & ChrW(58) & ChrW(32) & ChrW(1587) & ChrW(1606) & ChrW(1583) & ChrW(32) & ChrW(1583) & ChrW(1575) & ChrW(1585) & ChrW(1575) & ChrW(1740) & ChrW(32)
            warningText = warningText & ChrW(1578) & ChrW(1606) & ChrW(1592) & ChrW(1740) & ChrW(1605) & ChrW(1575) & ChrW(1578) & ChrW(32) & ChrW(1589) & ChrW(1601) & ChrW(1581) & ChrW(1575) & ChrW(1578) & ChrW(32)
            warningText = warningText & ChrW(1586) & ChrW(1608) & ChrW(1580) & ChrW(32) & ChrW(1608) & ChrW(32) & ChrW(1601) & ChrW(1585) & ChrW(1583) & ChrW(32) & ChrW(1605) & ChrW(1578) & ChrW(1601) & ChrW(1575) & ChrW(1608) & ChrW(1578) & ChrW(32)
            warningText = warningText & ChrW(1575) & ChrW(1587) & ChrW(1578) & ChrW(46) & ChrW(32) & ChrW(1575) & ChrW(1740) & ChrW(1606) & ChrW(32) & ChrW(1605) & ChrW(1575) & ChrW(1705) & ChrW(1585) & ChrW(1608) & ChrW(32)
            warningText = warningText & ChrW(1578) & ChrW(1606) & ChrW(1592) & ChrW(1740) & ChrW(1605) & ChrW(1575) & ChrW(1578) & ChrW(32) & ChrW(1585) & ChrW(1575) & ChrW(32) & ChrW(1576) & ChrW(1607) & ChrW(32)
            warningText = warningText & ChrW(1589) & ChrW(1608) & ChrW(1585) & ChrW(1578) & ChrW(32) & ChrW(1740) & ChrW(1705) & ChrW(1587) & ChrW(1575) & ChrW(1606) & ChrW(32)
            warningText = warningText & ChrW(1585) & ChrW(1608) & ChrW(1740) & ChrW(32) & ChrW(1607) & ChrW(1605) & ChrW(1607) & ChrW(32) & ChrW(1589) & ChrW(1601) & ChrW(1581) & ChrW(1575) & ChrW(1578) & ChrW(32)
            warningText = warningText & ChrW(1575) & ChrW(1593) & ChrW(1605) & ChrW(1575) & ChrW(1604) & ChrW(32) & ChrW(1605) & ChrW(1740) & ChrW(32) & ChrW(1705) & ChrW(1606) & ChrW(1583) & ChrW(46)

            warningTitle = ChrW(1607) & ChrW(1588) & ChrW(1583) & ChrW(1575) & ChrW(1585) & ChrW(32)
            warningTitle = warningTitle & ChrW(1602) & ChrW(1575) & ChrW(1604) & ChrW(1576) & ChrW(32)
            warningTitle = warningTitle & ChrW(1576) & ChrW(1606) & ChrW(1583) & ChrW(1740)

            MsgBox warningText, vbInformation, warningTitle
            warningShown = True
        End If

        ' درج سربرگ و پابرگ
        SetHeaderFooter sec, docTitle, authorName, solarDate
    Next sec

    ' انتقال مکان‌نما به انتهاي سند
    Selection.EndKey Unit:=wdStory

    ' پيام موفقيت
    Dim successMsg As String
    Dim successTitle As String

    successMsg = ChrW(10004) & ChrW(32) & ChrW(1587) & ChrW(1585) & ChrW(1576) & ChrW(1585) & ChrW(1711) & ChrW(32)
    successMsg = successMsg & ChrW(1608) & ChrW(32) & ChrW(1662) & ChrW(1575) & ChrW(1576) & ChrW(1585) & ChrW(1711) & ChrW(32)
    successMsg = successMsg & ChrW(1575) & ChrW(1587) & ChrW(1578) & ChrW(1575) & ChrW(1606) & ChrW(1583) & ChrW(1575) & ChrW(1585) & ChrW(1583) & ChrW(32)
    successMsg = successMsg & ChrW(1576) & ChrW(1607) & ChrW(32) & ChrW(1607) & ChrW(1605) & ChrW(1585) & ChrW(1575) & ChrW(1607) & ChrW(32)
    successMsg = successMsg & ChrW(1588) & ChrW(1605) & ChrW(1575) & ChrW(1585) & ChrW(1607) & ChrW(32) & ChrW(1589) & ChrW(1601) & ChrW(1581) & ChrW(1607) & ChrW(32)
    successMsg = successMsg & ChrW(1601) & ChrW(1575) & ChrW(1585) & ChrW(1587) & ChrW(1740) & ChrW(32) & ChrW(1608) & ChrW(1575) & ChrW(1602) & ChrW(1593) & ChrW(1740) & ChrW(32)
    successMsg = successMsg & ChrW(1583) & ChrW(1585) & ChrW(32) & ChrW(1578) & ChrW(1605) & ChrW(1575) & ChrW(1605) & ChrW(32) & ChrW(1576) & ChrW(1582) & ChrW(1588) & ChrW(32)
    successMsg = successMsg & ChrW(1607) & ChrW(1575) & ChrW(1740) & ChrW(32) & ChrW(1587) & ChrW(1606) & ChrW(1583) & ChrW(32) & ChrW(1583) & ChrW(1585) & ChrW(1580) & ChrW(32)
    successMsg = successMsg & ChrW(1588) & ChrW(1583) & ChrW(46)

    successTitle = ChrW(1593) & ChrW(1605) & ChrW(1604) & ChrW(1740) & ChrW(1575) & ChrW(1578) & ChrW(32)
    successTitle = successTitle & ChrW(1605) & ChrW(1608) & ChrW(1601) & ChrW(1602)

    MsgBox successMsg, vbInformation, successTitle
End Sub

Sub SetHeaderFooter(sec As Section, docTitle As String, authorName As String, convertedSolarDate As String)
    Dim hdr As HeaderFooter
    Dim ftr As HeaderFooter
    Dim fld As Field
    Dim pageField As Field
    Dim rng As Range

    ' تنظيم سربرگ‌ها
    For Each hdr In sec.Headers
        With hdr.Range
            .ParagraphFormat.Alignment = wdAlignParagraphRight
            .ParagraphFormat.ReadingOrder = wdReadingOrderRtl
            .Font.NameBi = "B Nazanin"
            .Font.SizeBi = 12
            .Font.Name = "Times New Roman"
            .Font.Size = 11
            .Text = ChrW(1593) & ChrW(1606) & ChrW(1608) & ChrW(1575) & ChrW(1606) & ChrW(32) & ChrW(1605) & ChrW(1602) & ChrW(1575) & ChrW(1604) & ChrW(1607) & ChrW(58) & ChrW(32) & docTitle & vbCrLf & ChrW(1606) & ChrW(1608) & ChrW(1740) & ChrW(1587) & ChrW(1606) & ChrW(1583) & ChrW(1607) & ChrW(58) & ChrW(32) & authorName
        End With
    Next hdr

    ' تنظيم پابرگ‌ها
    For Each ftr In sec.Footers
        Set rng = ftr.Range
        With rng
            .ParagraphFormat.Alignment = wdAlignParagraphCenter
            .ParagraphFormat.ReadingOrder = wdReadingOrderRtl
            .Font.NameBi = "B Nazanin"
            .Font.SizeBi = 11
            .Font.Name = "Times New Roman"
            .Font.Size = 10
            
            ' پاک کردن محتواي قبلي
            .Text = ""
            
            ' درج متن فارسي با ترتيب صحيح
            .InsertAfter ChrW(1578) & ChrW(1575) & ChrW(1585) & ChrW(1740) & ChrW(1582) & ChrW(58) & ChrW(32) & convertedSolarDate & ChrW(32) & ChrW(45) & ChrW(32) & ChrW(1589) & ChrW(1601) & ChrW(1581) & ChrW(1607) & ChrW(32)
            
            .Collapse Direction:=wdCollapseEnd

            ' حذف فيلدهاي قبلي
            For Each fld In .Fields
                If fld.Type = wdFieldPage Then fld.Delete
            Next fld

            ' درج شماره صفحه
            Set pageField = .Fields.Add(rng, wdFieldPage)
            pageField.Update

            ' تبديل شماره صفحه به ارقام فارسي واقعي
            pageField.Result.Text = ToPersianDigits(pageField.Result.Text)
        End With
    Next ftr
End Sub

Function ToPersianDigits(ByVal txt As String) As String
    txt = Replace(txt, "0", ChrW(1776))
    txt = Replace(txt, "1", ChrW(1777))
    txt = Replace(txt, "2", ChrW(1778))
    txt = Replace(txt, "3", ChrW(1779))
    txt = Replace(txt, "4", ChrW(1780))
    txt = Replace(txt, "5", ChrW(1781))
    txt = Replace(txt, "6", ChrW(1782))
    txt = Replace(txt, "7", ChrW(1783))
    txt = Replace(txt, "8", ChrW(1784))
    txt = Replace(txt, "9", ChrW(1785))
    ToPersianDigits = txt
End Function

Function ConvertToShamsi(miladiDate As Date) As String
    Dim gYear As Long, gMonth As Long, gDay As Long
    Dim g_d_m As Variant
    Dim jYear As Long, jMonth As Long, jDay As Long
    Dim gy As Long, gm As Long, gd As Long
    Dim g_day_no As Long, j_day_no As Long

    g_d_m = Array(0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334)

    gYear = Year(miladiDate)
    gMonth = Month(miladiDate)
    gDay = Day(miladiDate)

    gy = gYear - 1600
    gm = gMonth - 1
    gd = gDay - 1

    g_day_no = 365 * gy + (gy + 3) \ 4 - (gy + 99) \ 100 + (gy + 399) \ 400
    g_day_no = g_day_no + g_d_m(gm) + gd

    If (gm > 1 And ((gYear Mod 4 = 0 And gYear Mod 100 <> 0) Or (gYear Mod 400 = 0))) Then
        g_day_no = g_day_no + 1
    End If

    j_day_no = g_day_no - 79
    jYear = 979 + 33 * (j_day_no \ 12053)
    j_day_no = j_day_no Mod 12053
    jYear = jYear + 4 * (j_day_no \ 1461)
    j_day_no = j_day_no Mod 1461

    If j_day_no >= 366 Then
        jYear = jYear + ((j_day_no - 1) \ 365)
        j_day_no = (j_day_no - 1) Mod 365
    End If

    Dim j_m_days As Variant
    j_m_days = Array(31, 31, 31, 31, 31, 31, 30, 30, 30, 30, 30, 29)

    For jMonth = 0 To 11
        If j_day_no < j_m_days(jMonth) Then Exit For
        j_day_no = j_day_no - j_m_days(jMonth)
    Next jMonth

    jMonth = jMonth + 1
    jDay = j_day_no + 1

    ' فرمت روز/ماه/سال با ارقام فارسي
    ConvertToShamsi = ToPersianDigits(Format(jDay, "00")) & "/" & ToPersianDigits(Format(jMonth, "00")) & "/" & ToPersianDigits(CStr(jYear))
End Function

نکات مهم و راهنمای استفاده حرفه‌ای :light_bulb:

  • ورودی یک‌بار: ماکرو فقط یک‌بار عنوان مقاله و نام نویسنده را از شما می‌پرسد و آن را روی همه بخش‌ها اعمال می‌کند.

  • شماره صفحه با ارقام فارسی واقعی: به‌جای تکیه بر شکل ظاهری فونت، اعداد واقعی یونیکد فارسی درج می‌شوند، که برای جست‌وجو و پردازش متنی هم درست کار می‌کنند.

  • تاریخ شمسی دقیق: با استفاده از الگوریتم جلالی، بدون خطای کبیسه یا جابه‌جایی نوروز.

  • قابل شخصی‌سازی: می‌توانید نام فونت، اندازه و محل درج شماره صفحه را به دلخواه تغییر دهید.

  • ذخیره ماکرو: برای استفاده دائمی از این ماکرو در همه اسناد، آن را در قالب Normal.dotm ذخیره کنید. همچنین هنگام ذخیره سند، از قالب Word Macro-Enabled Document (.docm) استفاده نمایید تا ماکروها حذف نشوند. :floppy_disk:

  • نحوه اجرای آسان: می‌توانید این ماکرو را به نوار ابزار دسترسی سریع (Quick Access Toolbar) اضافه کنید تا با یک کلیک ساده در هر سندی قابل اجرا باشد. :high_voltage:

نتیجه‌گیری :flexed_biceps:

این ماکرو، یک دستیار قالب‌بندی هوشمند برای اسناد فارسی است. با آن، در چند ثانیه سند شما سربرگ و پابرگ استاندارد، تاریخ شمسی و شماره صفحه فارسی واقعی خواهد داشت. این ماکرو به شما کمک می‌کند تا زمان بیشتری را به محتوای اصلی خود اختصاص دهید و از دردسرهای فرمت‌بندی رها شوید.