Sub ConvertNumbersToDate()
    Dim myRange As Range
    Set myRange = ActiveDocument.Content
    
    With myRange.Find
        .ClearFormatting
        .Text = "([0-9]{8})"
        .Forward = True
        .MatchWildcards = True
        .Wrap = wdFindContinue
        
        Do While .Execute
            Dim numberStr As String
            numberStr = myRange.Text
            
            If Left(numberStr, 3) = "140" Or Left(numberStr, 3) = "139" Then
                Dim year As String, month As String, day As String
                year = Left(numberStr, 4)
                month = Mid(numberStr, 5, 2)
                day = Right(numberStr, 2)
                
                Dim newDate As String
                
                newDate = day & "/" & month & "/" & year
                
                myRange.Text = newDate
'                myRange.ParagraphFormat.ReadingOrder = wdReadingOrderRtl
'                myRange.ParagraphFormat.Alignment = wdAlignParagraphRight
            End If
        Loop
    End With
End Sub



Sub SavePagesToPDFWithIncrementalNames()
    Dim doc As Document
    Dim pageRange As Range
    Dim pageCount As Long
    Dim i As Long
    Dim fileNumber As Long
    Dim saveDirectory As String
    Dim userInput As String
    
    Set doc = ActiveDocument
    
    userInput = InputBox("لطفاً شماره اوليه براي نامگذاري فايل‌ها را وارد کنيد:")
    
    If Not IsNumeric(userInput) Then
        MsgBox "لطفاً يک عدد معتبر وارد کنيد."
        Exit Sub
    End If
    
    fileNumber = CLng(userInput)
    saveDirectory = "D:\PDFs\"
    
    If Dir(saveDirectory, vbDirectory) = "" Then
        MkDir saveDirectory
    End If
    
    pageCount = doc.ComputeStatistics(wdStatisticPages)
    
    For i = 1 To pageCount
        If i < pageCount Then
            Set pageRange = doc.Range( _
                Start:=doc.GoTo(What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=i).Start, _
                End:=doc.GoTo(What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=i + 1).Start - 1)
        Else
            Set pageRange = doc.Range( _
                Start:=doc.GoTo(What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=i).Start, _
                End:=doc.Content.End)
        End If
        
        Dim tempDoc As Document
        Set tempDoc = Documents.Add(Visible:=False)
        
        pageRange.Copy
        tempDoc.Range.PasteAndFormat wdFormatOriginalFormatting
        
        ' کپی پس‌زمینه و واترمارک
        Dim section As Section
        For Each section In doc.Sections
            tempDoc.Sections(1).Headers(wdHeaderFooterPrimary).Range.FormattedText = section.Headers(wdHeaderFooterPrimary).Range.FormattedText
            tempDoc.Sections(1).Footers(wdHeaderFooterPrimary).Range.FormattedText = section.Footers(wdHeaderFooterPrimary).Range.FormattedText
        Next
        
        ' تنظیم اندازه صفحه به A4 افقی با کمترین حاشیه
        With tempDoc.PageSetup
            .PaperSize = wdPaperA4
            .Orientation = wdOrientLandscape
            .TopMargin = CentimetersToPoints(0.5)
            .BottomMargin = CentimetersToPoints(0.5)
            .LeftMargin = CentimetersToPoints(0.5)
            .RightMargin = CentimetersToPoints(0.5)
        End With
        
        Dim savePath As String
        savePath = saveDirectory & fileNumber & ".pdf"
        
        tempDoc.ExportAsFixedFormat OutputFileName:=savePath, _
            ExportFormat:=wdExportFormatPDF, OpenAfterExport:=False, _
            OptimizeFor:=wdExportOptimizeForPrint
            
        tempDoc.Close SaveChanges:=False
        
        Debug.Print "صفحه " & i & " ذخيره شد با نام: " & fileNumber & ".pdf"
        
        fileNumber = fileNumber + 1
    Next i
    
    MsgBox "تمام صفحات با موفقيت در درايو D\PDFs ذخيره شدند."
End Sub