استخراج النصوص المميزة إلى ملف آخر مع أرقام الصفحات:

[أبو عاصم المصري]

يحتاج الباحث كثيرا إلى استخراج النصوص المميزة إلى ملف آخر مع أرقام الصفحات للنظر فيها بشكل مستقل، وهذا ماكرو لذلك:

Dim oRng, oNrng As Range
Dim oSource, oDoc As Document
Dim oTable As Table
Dim iRow, iPage, ILen As Integer
Dim iPara, iIst, iLast As Integer
Dim sFont, SComp, sNext, sWords As String
Dim sColor As WdColor
Set oSource = ActiveDocument
Set oDoc = Documents.Add
Set oTable = oDoc.Tables.Add(oDoc.Range, 2, 2)
With oTable
.Cell(1, 1).Range.Text = "النص المميز"
.Cell(1, 2).Range.Text = "الصفحة"
'.Cell(1, 3).Range.Text = "Font" لاستخراج اسم الخط
'.Cell(1, 4).Range.Text = "Comments" لاستخراج لون التمييز
With .Rows(1).Range
.ParagraphFormat.Alignment = _
wdAlignParagraphCenter
.Font.name = "Arial"
.Font.Size = "12"
.Bold = True
End With
End With
oSource.Activate
With Selection
.HomeKey Unit:=wdStory
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = ""
.Highlight = True
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = False
Do While .Execute = True
Set oRng = Selection.Range
With oRng
iIst = .Start - .Words.First.Start + 1
iLast = .Words.Last.End - .End
sNext = .Next.Characters(1)
sColor = .HighlightColorIndex
If .Start <> .Words.First.Start Or _
.End <> .Words.Last.End - 1 And _
sNext <> "" Then
Select Case sNext
Case ",", ".", "?", "!", ":", ";"
SComp = ""
iLast = iLast + 1
Case Else
SComp = "Partly highlighted"
End Select
Else
SComp = ""
End If
.Start = .Words.First.Start
.End = .Words.Last.End
If .Characters.Last = Chr(32) Then
.End = .Words.Last.End - 1
End If
sFont = .Font.name
If Len(sFont) < 1 Then sFont = "Mixed fonts detected"
iPage = .Information(wdActiveEndPageNumber)
iRow = oTable.Rows.Count
oTable.Cell(iRow, 1).Range.FormattedText = oRng.FormattedText
oTable.Cell(iRow, 2).Range.Text = iPage
oTable.Cell(iRow, 2).Range.ParagraphFormat.Alignment _
= wdAlignParagraphCenter
'oTable.Cell(iRow, 3).Range.Text = sFont لاستخراج اسم الخط
'oTable.Cell(iRow, 4).Range.Text = SComp لاستخراج لون التمييز
oTable.Rows.Add
End With
Loop
End With
End With
oTable.Rows.Last.Delete
oDoc.Activate
Beep
End Sub

[محمد سيد٧٩]

ممكن طريقة تنفيذه على مثال مشكورا

[أبو عاصم المصري]

الأمر بسيط، فلو أنك فتحت أي ملف فيه كلمات مميزة بأي لون، وشغلت الماكرو سيقوم الماكرو باستخراج كل الكلمات أو الجمل المميزة مع أرقام صفحاتها إلى ملف آخر.