וורד האשכול המרכזי לשאלות וטיפים בוורד

[moishy]

בוורד אין אוסף מילים בהיררכיית האוספים. באמת מעצבן בהרבה מקרים, אבל אי אפשר לעבור מילה מילה כמו שאפשר לעבור תו תו ופסקה פסקה.

א"כ מה זה?

Selection.[B]Words[/B]

 

[moishy]

זה אפשרי, עם כי בדרכים עקיפות.
למשל, אני בוחר (ע"י חיפוש) את כל הטקסט האוטומטי, ומעצבו בקו תחתון. ולאחר מכן בוחר (ע"י חיפוש), כל אשר אינו בקו תחתון.

עד כמה שידוע לי אין אפשרות לחפש בשלילה, ומ"מ יש פתרון המודגם בקוד הבא

Sub FindNotBlack()
    Dim rDcm As Range
    Set rDcm = ActiveDocument.Range
    With rDcm.Find
        .Text = "<*>"
        .MatchWildcards = True
        While .Execute
            If rDcm.Font.Color <>wdColorAutomatic Then
                            rDcm.Font.Color = wdColorRed
            End If
        Wend
    End With
End Sub

 

[Yisrael]

ראשית, תודה רבה!

צירפתי תמונה של הודעת השגיאה.

ושוב תודה!
אין מילים!

על פניו זה נראה שיש לו איזה בעיה עם ההקצאה של המילה start למשתנה, אולי הוא מוקצה לאיזו פונקציה כללית או משהו כזה, תנסה לשנות את המילה למשהו אחר (בכל המופעים שלה בשגרה) ונראה מה יהיו חלומותיו.

זה אפשרי, עם כי בדרכים עקיפות.
למשל, אני בוחר (ע"י חיפוש) את כל הטקסט האוטומטי, ומעצבו בקו תחתון. ולאחר מכן בוחר (ע"י חיפוש), כל אשר אינו בקו תחתון.

למעשה יכול להיות שאפשר להשתמש באופציה הזאת בקוד, אבל תנסה בקוד המצורף לראות אם זה עדיין בעייתי כי הוא עובר מילה מילה וזה הרבה יותר מהיר.

האמת שחשבתי בהתחלה לחפש את הצבע האוטומטי ואז למצוא את מיקומו של הטקסט שאינו אוטומטי ע"י סוף הבחירה שאחרי החיפוש ותחילת הבחירה של החיפוש הבא.
אבל משום מה שמתי לב שכשמחפשים טקסט בצבע אוטומטי (אולי גם בשאר צבעים לא ניסיתי) הוא מוצא את הטקסט עד סוף הפסקה, מה שיכול ליצור בעיה ומצריך קוד מורכב יותר. לכן ניסיתי ללכת בדרך אחרת.

א"כ מה זה?

Selection.[B]Words[/B]

צודק, טעות שלי שכחתי את האופציה הזו, וצירפתי קוד משופר על פי דבריך. תודה.

Sub העתקת__טקסט_צבוע()
Dim MyArray() As Variant
For i = 1 To ActiveDocument.Words.Count
    If Not ActiveDocument.Words(i).Font.ColorIndexBi = wdAuto Then
      start = ActiveDocument.Words(i).start
        For t = i To ActiveDocument.Words.Count
        f = f + 1
          If ActiveDocument.Words(t).Font.ColorIndexBi = wdAuto Then
            endd = ActiveDocument.Words(t).start
            Selection.SetRange start, endd
            y = y + 1
            ReDim Preserve MyArray(y)
            MyArray(y) = Selection.Range & "-" & Selection.Information(wdActiveEndPageNumber)
            i = i + f
            Exit For
            End If
        Next t
    End If
Next i

Documents.Add
  For E = 1 To y
    ActiveDocument.Paragraphs(E).Range = MyArray(E)
      If E < y Then
        Selection.EndKey wdStory
        ActiveDocument.Paragraphs.Add Selection.Range
      End If
  Next E
End Sub

עד כמה שידוע לי אין אפשרות לחפש בשלילה, ומ"מ יש פתרון המודגם בקוד הבא

Sub FindNotBlack()
    Dim rDcm As Range
    Set rDcm = ActiveDocument.Range
    With rDcm.Find
        .Text = "<*>"
        .MatchWildcards = True
        While .Execute
            If rDcm.Font.Color <>wdColorAutomatic Then
                            rDcm.Font.Color = wdColorRed
            End If
        Wend
    End With
End Sub

הקוד הזה בעצם גם עובר מילה מילה בחיפוש, כך שאין בזה רווח משמעותי.
מה גם שנצטרך לבחור את המילה שנמצאה בחיפוש ולצבור מילה מילה, לא בטוח שזה יהיה מהיר יותר בסופו של דבר.
בכל אופן זה רעיון טוב.

 

[אלחנן אריאל]

עד כמה שידוע לי אין אפשרות לחפש בשלילה,
[/CODE]

א"כ מה זה?

 

[אלחנן אריאל]

על פניו זה נראה שיש לו איזה בעיה עם ההקצאה של המילה start למשתנה, אולי הוא מוקצה לאיזו פונקציה כללית או משהו כזה, תנסה לשנות את המילה למשהו אחר (בכל המופעים שלה בשגרה) ונראה מה יהיו חלומותיו.

שיניתי את המלה start, ואכן אינו נתקע!
אציין, כי לא את כל מילות start היה צריך לשנות. למשל בשורה הזו:

 start = ActiveDocument.Words(i).start

היה צריך לשנות את אשר בפתיחת השורה, ולא את זו שבחתימתה.

צירפתי קוד משופר.

Sub העתקת__טקסט_צבוע()
Dim MyArray() As Variant
For i = 1 To ActiveDocument.Words.Count
    If Not ActiveDocument.Words(i).Font.ColorIndexBi = wdAuto Then
      start = ActiveDocument.Words(i).start
        For t = i To ActiveDocument.Words.Count
        f = f + 1
          If ActiveDocument.Words(t).Font.ColorIndexBi = wdAuto Then
            endd = ActiveDocument.Words(t).start
            Selection.SetRange start, endd
            y = y + 1
            ReDim Preserve MyArray(y)
            MyArray(y) = Selection.Range & "-" & Selection.Information(wdActiveEndPageNumber)
            i = i + f
            Exit For
            End If
        Next t
    End If
Next i

Documents.Add
  For E = 1 To y
    ActiveDocument.Paragraphs(E).Range = MyArray(E)
      If E < y Then
        Selection.EndKey wdStory
        ActiveDocument.Paragraphs.Add Selection.Range
      End If
  Next E
End Sub

אכן, זה עבד, נפלא הפלא ופלא.
אך לא פעל על כל הטקסט שצבעם שונה. כי אם על כ15% מהם.
אתמהה?!


שוב יישר כחך ר' ישראל!
תודה רבה עד מאוד!

 

[אלחנן אריאל]

יש פתרון המודגם בקוד הבא

Sub FindNotBlack()
    Dim rDcm As Range
    Set rDcm = ActiveDocument.Range
    With rDcm.Find
        .Text = "<*>"
        .MatchWildcards = True
        While .Execute
            If rDcm.Font.Color <>wdColorAutomatic Then
                            rDcm.Font.Color = wdColorRed
            End If
        Wend
    End With
End Sub

לא זכיתי להבין, איזה חלק הקוד הזה אמור לפתור?
אצלי הוא לא הביאני לתכלית הנרצית.

 

[אלחנן אריאל]

לא פעל על כל הטקסט שצבעם שונה. כי אם על כ15% מהם.
אתמהה?!


שוב יישר כחך ר' ישראל!
תודה רבה עד מאוד!

הרצתי את המאקרו שוב, וראיתי שהוא עובר על המסמך ובוחר כל מקבץ טקסט שאינו בצבע אוטומטי, ואכן מדלג על חלקם.

 

[moishy]

א"כ מה זה?

צודק שכחתי מזה.

 

[moishy]

הרצתי את המאקרו שוב, וראיתי שהוא עובר על המסמך ובוחר כל מקבץ טקסט שאינו בצבע אוטומטי, ואכן מדלג על חלקם.

הקוד הזה לא אמור לפתור דבר, הוא מיועד למתכנתים שבינינו, להדגים כיצד ניתן לעשות חיפוש בחיוב עם סינון בשלילה.

 

[Yisrael]

שיניתי את המלה start, ואכן אינו נתקע!
אציין, כי לא את כל מילות start היה צריך לשנות. למשל בשורה הזו:

 start = ActiveDocument.Words(i).start

היה צריך לשנות את אשר בפתיחת השורה, ולא את זו שבחתימתה.

ברור! שכחתי לציין זאת, אבל המילה start שבתחילת המילה היא משתנה שהקציתי לו שם בעלמא, כנראה שהשם הזה מוקצה אצלך למשהו אחר וזו הייתה הבעיה. מה-שאין-כן המילה start שבסוף השורה שהיא אינה המשתנה הלז כלל וכלל וצריכה להישאר כמות שהיא.

לא זכיתי להבין, איזה חלק הקוד הזה אמור לפתור?
אצלי הוא לא הביאני לתכלית הנרצית.

אם הבנתי אותו נכון הוא רק התכוון להדגים שניתן למצוא כל מילה שאינה בצבע האוטומטי, ע"י חיפוש כל מילה ובאם צבעה אינו אוטומטי לעצור. בדוגמה שלו הטקסט שצבעו אינו אוטומטי נהפך לצבע אחר, אבל לפי הבנתי זה רק לשם הדוגמה.

הרצתי את המאקרו שוב, וראיתי שהוא עובר על המסמך ובוחר כל מקבץ טקסט שאינו בצבע אוטומטי, ואכן מדלג על חלקם.

מוזר ביותר!

האם יש איזו הודעת שגיאה או שהוורד נתקע או משהו? או שפשוט הוא מסיים חלק ונותן תוצאה של חלק מהטקסטים?

האם מדובר על המסמך שהעלית כאן? אם לא אולי תוכל לתת הורדה שלו?

בשמחה...

 

[moishy]

הנה פתרון פשוט, בדוק ומנוסה.

Sub העתקת_טקסט_צבעוני()
    Application.Documents.Add ActiveDocument.FullName
    Application.ScreenUpdating = False
    With ActiveDocument.Content
        With .Find
            .ClearFormatting
            .Replacement.ClearFormatting
            .Forward = False
            .Wrap = wdFindStop
            .Format = True
            .Text = ""
            .Font.ColorIndex = wdAuto
            .Execute
        End With
        Do While .Find.Found
            .Text = vbTab & "עמוד " & .Duplicate.Characters.First.Information(wdActiveEndPageNumber) & vbCr
            .Collapse wdCollapseStart
            .Find.Execute
        Loop
        With .Find
            .ClearFormatting
            .Replacement.ClearFormatting
            .Wrap = wdFindContinue
            .Format = False
            .MatchWildcards = True
            .Text = "^13^tעמוד [0-9]{1,2}"
            .Replacement.Text = ""
            .Execute Replace:=wdReplaceAll
        End With
        .Paragraphs.First.Range.Delete
    End With
    ActiveDocument.Range.Characters.Last.Previous.Delete
    Application.ScreenUpdating = True
End Sub

 

[אלחנן אריאל]

תודה רבה לר' ישראל,
שהביא לפתרון הרצוי,
בקוד הזה:

Sub העתקת_טקסט_צבוע()

Dim MyArray() As Variant

Selection.Find.ClearFormatting: Selection.Find.Font.ColorIndexBi = wdRed
a:
  If Selection.Find.Execute(findtext:="") Then
    y = y + 1
    ReDim Preserve MyArray(y)
    MyArray(y) = Selection.Range & " -" & Selection.Information(wdActiveEndPageNumber)
    GoTo a
  End If

Documents.Add
  For E = 1 To y
    ActiveDocument.Paragraphs(E).Range = MyArray(E)
      If E < y Then
        Selection.EndKey wdStory
        ActiveDocument.Paragraphs.Add Selection.Range
      End If
  Next E
End Sub

זה לאחר שכל המשפטים האמורים להשלף, נצבעו באדום.

 

[moishy]

תודה רבה לר' ישראל,
שהביא לפתרון הרצוי,
בקוד הזה:

Sub העתקת_טקסט_צבוע()

Dim MyArray() As Variant

Selection.Find.ClearFormatting: Selection.Find.Font.ColorIndexBi = wdRed
a:
  If Selection.Find.Execute(findtext:="") Then
    y = y + 1
    ReDim Preserve MyArray(y)
    MyArray(y) = Selection.Range & " -" & Selection.Information(wdActiveEndPageNumber)
    GoTo a
  End If

Documents.Add
  For E = 1 To y
    ActiveDocument.Paragraphs(E).Range = MyArray(E)
      If E < y Then
        Selection.EndKey wdStory
        ActiveDocument.Paragraphs.Add Selection.Range
      End If
  Next E
End Sub

זה לאחר שכל המשפטים האמורים להשלף, נצבעו באדום.

אצלי זה פעל פחות טוב מהגירסא המקורית של ר' ישראל, רק אחוז מזערי של הצבועים באדום אכן חולצו.

 

[זאבי]

תודה רבה! הקוד של הדגשת מילה ראשונה בכל קטע מאוד עזר גם לי,
הבעיה היא שבמקרה שהמילה הראשונה מורכבת מראשי תיבות, זה נעצר במרכאות,
לדוגמא אם תחילת קטע הוא: תשר"ת בחירת הקוד הנ"ל מסמנת רק תשר.
האם יש דרך להתגבר על זה?

 

[דודו10]

שלום,
כן גם אני הבחנתי בבעיה הזאת

אם למישהו יש פתרון, אשמח לשמוע

ושוב תודה

 

[eliezer]

שלום,
כן גם אני הבחנתי בבעיה הזאת

אם למישהו יש פתרון, אשמח לשמוע

ושוב תודה

(^013[! ]@ )

כותב מהזכרון, נסה.
אמור לעבוד בכל הספר חוץ מהפסקה הראשונה.

לפני הרצתו בדוק שאין רווח בתחילת פסקה על ידי
(^013)( ) והחלף ב\1

 

[Yisrael]

תנסה במקום הסימן "<" שבקוד הנ"ל - לשים רווח.

 

[דודו10]

שלום

בקיצור האם מישהו יוכל לכתוב לי מסודר את הדוק המדוייק שצריך לכתוב עבור הדגשה של אות ראשונה כולל מרכאות

תודה

 

[eliezer]

שלום

בקיצור האם מישהו יוכל לכתוב לי מסודר את הדוק המדוייק שצריך לכתוב עבור הדגשה של אות ראשונה כולל מרכאות

תודה

אות או מילה?
מילה כבר כתבו בשתי צורות שונות. אני מעדיף את שלי כי בטוח לא יבחר יותר ממילה אחת.

 

[Yisrael]

אצלי זה פעל פחות טוב מהגירסא המקורית של ר' ישראל, רק אחוז מזערי של הצבועים באדום אכן חולצו.

מוזר!

יש לך הסבר לזה? (מעניין לראות את הקובץ בשביל להחכים)