استخراج تمييز بلون محدد من مستند إلى مستند آخر:

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

قد يوجد في المستند الواحد العديد من العبارات المميزة بألوان مختلفة (أصفر، أخضر،..)، وقد تحتاج إلى نقل تمييز بلون محدد إلى ملف آخر للنظر فيه.

وهذا الماكرو يقوم بذلك:

ss = InputBox(" : اختر رقم لون التمييز " & vbNewLine & _
      vbTab & "تلقائي" & vbTab & vbTab & "0" & vbNewLine & _
      vbTab & "أسود" & vbTab & vbTab & "1" & vbNewLine & _
      vbTab & "أزرق" & vbTab & vbTab & "2" & vbNewLine & _
      vbTab & "أخضر فاتح" & vbTab & "4" & vbNewLine & _
      vbTab & "أزرق غامق" & vbTab & vbTab & "9" & vbNewLine & _
      vbTab & "أحمر غامق" & vbTab & vbTab & "13" & vbNewLine & _
      vbTab & "أصفر غامق" & vbTab & "14" & vbNewLine & _
      vbTab & "رمادي 25" & vbTab & vbTab & "16" & vbNewLine & _
      vbTab & "رمادي 50" & vbTab & vbTab & "15" & vbNewLine & _
      vbTab & "أخضر" & vbTab & vbTab & "11" & vbNewLine & _
      vbTab & "قرنفلي" & vbTab & vbTab & "5" & vbNewLine & _
      vbTab & "أحمر" & vbTab & vbTab & "6" & vbNewLine & _
      vbTab & "نهري" & vbTab & vbTab & "10" & vbNewLine & _
      vbTab & "تركواز" & vbTab & "3" & vbNewLine & _
      vbTab & "بنفسجي" & vbTab & vbTab & "12" & vbNewLine & _
      vbTab & "أبيض" & vbTab & vbTab & "8" & vbNewLine & _
      vbTab & "أصفر" & vbTab & vbTab & "7", "قائــــــــــــــمة الألــــــوان")

    
    Documents.Add DocumentType:=wdNewBlankDocument
    Windows(2).Activate
  Selection.HomeKey wdStory
Start:
Selection.Find.ClearFormatting
Selection.Find.Highlight = True
With Selection.Find
    .Text = ""
    .Replacement.Text = ""
    .Forward = True
    .Wrap = wdFindStop
    .Format = True
    .MatchCase = False
    .MatchWholeWord = False
    .MatchWildcards = False
    .MatchSoundsLike = False
    .MatchAllWordForms = False
    .Execute
If .Found Then
If Selection.Range.HighlightColorIndex = ss Then
End If
AAAM = AAAM + 1
GoTo Start
Else
End If
End With
Selection.HomeKey wdStory

For X = 1 To AAAM + 1

Selection.Find.ClearFormatting
Selection.Find.Highlight = True
With Selection.Find
    .Text = ""
    .Replacement.Text = ""
    .Forward = True
    .Wrap = wdFindStop
    .Format = True
    .MatchCase = False
    .MatchWholeWord = False
    .MatchWildcards = False
    .MatchSoundsLike = False
    .MatchAllWordForms = False
    .Execute
    End With
    If Selection.Range.HighlightColorIndex = ss Then ' لو كان النص المظلل باللون المحدد

  Selection.Copy
   On Error Resume Next
    Windows(1).Activate
    Selection.PasteAndFormat (wdFormatOriginalFormatting)
    Selection.TypeParagraph
    Windows(2).Activate
    
   ' Selection.range.HighlightColorIndex = 0 ' احذف التمييز
    End If
    Selection.Collapse (wdCollapseEnd)
    Next
Beep
MsgBox "تم نسخ التمييز المطلوب إلى ملف آخر، والحمد لله رب العالمين"
Selection.HomeKey Unit:=wdStory
Beep
End Sub