أبو عاصم المصري قام بنشر فبراير 8, 2023 مشاركة قام بنشر فبراير 8, 2023 يحتاج الباحث كثيرا إلى استخراج النصوص المميزة إلى ملف آخر مع أرقام الصفحات للنظر فيها بشكل مستقل، وهذا ماكرو لذلك: 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 1 رابط هذا التعليق شارك More sharing options...
محمد سيد٧٩ قام بنشر ديسمبر 5, 2023 مشاركة قام بنشر ديسمبر 5, 2023 ممكن طريقة تنفيذه على مثال مشكورا رابط هذا التعليق شارك More sharing options...
أبو عاصم المصري قام بنشر ديسمبر 7, 2023 الكاتب مشاركة قام بنشر ديسمبر 7, 2023 الأمر بسيط، فلو أنك فتحت أي ملف فيه كلمات مميزة بأي لون، وشغلت الماكرو سيقوم الماكرو باستخراج كل الكلمات أو الجمل المميزة مع أرقام صفحاتها إلى ملف آخر. رابط هذا التعليق شارك More sharing options...
الردود الموصى بها
Join the conversation
You can post now and register later. If you have an account, sign in now to post with your account.