Jump to content
بحث مخصص من جوجل فى أوفيسنا
Custom Search
جمال جبريل

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

Recommended Posts

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

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."wink_3
    '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
      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
        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) '
        .Cell(nRow, 5).Range.Text = objBookmark.Range.Information(wdVerticalPositionRelativeToPage)
        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

Share this post

Link to post
Share on other sites

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

Reply to this topic...

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

  • Recently Browsing   0 members

    No registered users viewing this page.

  • Create New...