سؤال اضافة اشارات مرجعية بناء على معلومات من جدول

[جمال جبريل]

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

Sub ExtractBookmarksInSameDoc()
  Dim objBookmark As Bookmark
  Dim objTable As Table
  Dim nRow As Integer
  Dim objDoc As d*ocument, objNewDoc As d*ocument
  Dim objParagraph As Paragraph
 
  Set objDoc = Actived*ocument
 
  If objDoc.Bookmarks.Count = 0 Then
    MsgBox ("There is no bookmark in this d*ocument."
  Else
    'Set objNewDoc = d*ocuments.Add
 
    Selection.TypeText Text:="Bookmarks in " & "'" & objDoc.Name & "'"
 
    Set objTable = Selection.Tables.Add(Range:=Selection.Range, numrows:=1, numcolumns:=5)
    objTable.Borders.Enable = True
    nRow = 1
 
    For Each objParagraph In objDoc.Paragraphs
      If objParagraph.Range.Style = "Caption" Then
        objParagraph.Range.Delete
      End If
    Next objParagraph
 
    With objTable
      .Cell(1, 1).Range.Text = "Name"
      .Cell(1, 2).Range.Text = "Sections"
      .Cell(1, 3).Range.Text = "Page Number"
        .Cell(1, 4).Range.Text = "lines"
        .Cell(1, 5).Range.Text = "Colm"
      For Each objBookmark In objDoc.Bookmarks
        objTable.Rows.Add
        nRow = nRow + 1
        .Cell(nRow, 1).Range.Text = objBookmark.Name
        .Cell(nRow, 2).Range.Text = objBookmark.Range.Information(wdActiveEndSectionNumber)
        .Cell(nRow, 3).Range.Text = objBookmark.Range.Information(wdActiveEndAdjustedPageNumber)
        .Cell(nRow, 4).Range.Text = objBookmark.Range.Information(wdFirstCharacterLineNumber) '
        '(wdVerticalPositionRelativeToPage)
        '(wdFirstCharacterLineNumber)
        
        .Cell(nRow, 5).Range.Text = objBookmark.Range.Information(wdVerticalPositionRelativeToPage)
        '(wdStartOfRangeColumnNumber)'(wdHorizontalPositionRelativeToTextBoundary)'(wdActiveEndAdjustedPageNumber)'(wdActiveEndAdjustedPageNumber)
        
        objDoc.Hyperlinks.Add Anchor:=.Cell(nRow, 3).Range, Address:=objDoc.Name, _
          SubAddress:=objBookmark.Name, TextToDisplay:=.Cell(nRow, 3).Range.Text
      Next objBookmark
    End With
  End If
  'objNewDoc.SaveAs2 FileName:=objDoc.Path & "" & "Bookmarks in " & objDoc.Name
End Sub

سؤال لادراج الاشارات المرجعية برقم الصفحة ورقم السطر.rar

[مصطفى شاهين]

السلام عليكم

حاولت تطبيق الماكرو لكن أعطاني إشارة بوجود مشكلة.

يرجى إرفاق الماكرو بملف text

دمتم بخير