התאמת טקסט לטבלא

[tkh]

אני מקליד שמות אנשים בטבלא גדולה.
(גודל הטקסט 6.5, מודפס אח"כ בהגדלה ל-A3).
גודל התא כ0.7 רוחב על 0.9 גובה.
הבעיה ששמות קצת ארוכים (לדוג' זילברשטיין) לא נכנסים.
אני עובר ידנית אחד אחד ומצר אותם ל-90%, אם לא עוזר ל-85%, לא עוזר מקטין הכתב ל-6 נק', לא עוזר עדיין, מוריד אותיות... (למשל כפילות י').
האם אפשר לתת איזה מאקרו לזה???
(נ.ב. התאמת טקס אוטומטית לא פועל, עושה רק להיפך שמילים קטנות יותר מרוחות על גבי כל השורה).
בתודה

 

[צורת הדף]

נסית Autofit to Contents?

 

[tkh]

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

 

[גרף]

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

השאלה אם אתה לא מוגבל במקום (ככה זה נראה לפי השאלה של&#1498.

 

[אברימי]

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

 

[tkh]

אכן מקומות, לא לגור, אבל 550 מקומות
אינני רוצה להרחיב או להצר את הטורים, וגם לא להקטין את הכל, אלא רק בפקודה (במקום ידנ&#1497 כל מה שגודל המילה יותר מכך וכך מ"מ ולא נכנס לשורה, להצר ו/או להקטין.
(ב"משלים לוורד" יש כל מיני פקודות שמבוססות על מדידה של גובה של שורות, ואורך של שורות, וחלוקתם, וכדו'. השאלה אם יש גם מדידה שתתן תוצאה של אורך מילה במ"מ.)

 

[אברימי]

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

 

[צורת הדף]

מיוחד ל-tkh

מאקרו זה יתן לך רוחב המילים בכל התאים שבחרת.

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

Sub word_width_in_table()
For i = 1 To Selection.Cells.Count
Selection.MoveRight Unit:=wdCell
w1 = PointsToMillimeters(Selection.Information(wdHorizontalPositionRelativeToPage))
Selection.Collapse Direction:=wdCollapseEnd
w2 = PointsToMillimeters(Selection.Information(wdHorizontalPositionRelativeToPage))
w3 = w1 - w2
MsgBox "Cell " & i & " = " & w3 & " Millimeters."
Next i
End Sub

 

[צורת הדף]

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

אני חושב שנסית fit text במאפיינים של הטבלה, ולא Autofit to Contents שזה בסרגלים

 

[tkh]

אני צריך את שמו בעברית. אינני מוצא משהו דומה בסרגלים (באיזה סרגל זה אמור להופיע? טבלא??)

 

[צורת הדף]

בוורד 2007
צפה בקובץ המצורף 23107

בוורד 2003 בתפריט טבלא (לא בסרגלים), איני יודע איפה.
מישהו יש לו וורד 2003 לבדוק?

 

[tkh]

קרש
רק עכשיו ראיתי את תגובתך בכתיבת הקוד.
רוחב הטור בטבלא הוא 0.7 ס"מ.
גודל האות הוא 6.5, מעוניין בעיקרון להקטין הרוחב אות ל90%, אם עדיין לא עוזר ל85%, לא עזר להקטין גודל אות ל-6.
יישר כחך על כל הטירחה ומהאמץ - עכשיו, ותמיד!

 

[צורת הדף]

בוורד אי אפשר להקטין גודל האות לפי אחוז.
גודל 6 מתאים לכל המקרים?

 

[tkh]

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

 

[לייזער]

המאקרא דלהלן מקצר פיסקאות (הנבחרו&#1514 לכדי שורה אחת – לפי המידע הרשום בתחילת המאקרא (שורות Const [וכולל בו הגדרות גודל והצרה: ברירת מחדל; מינימום; כמות הקטנה בכל נסיון]). הזנת המידע (בשורות הנ"&#1500 נעשתה ע"פ מה שכתב tkh, אך אפשר כמובן לשנות שם עוד כפי הנרצה.

[LEFT]Sub ParaForceOneLine()
    Dim objPara As Paragraph, i As Integer
    Const DefaultScale = 100, DefaultSize = 6.5
    Const MinScale = 85, MinSize = 6
    Const ChangeScale = 5, ChangeSize = 0.5
    For Each objPara In Selection.Paragraphs
        With objPara.Range
            If Len(objPara.Range) <= 2 Then GoTo sNext
            If .Information(wdWithInTable) Then i = 2 Else i = 0
            While .Information(wdFirstCharacterLineNumber) <> _
                .Characters(Len(.Text) - i).Information(wdFirstCharacterLineNumber)
                If .Font.Scaling > DefaultScale Or .Font.SizeBi > DefaultSize Then
                    .Font.Scaling = DefaultScale: .Font.SizeBi = DefaultSize: GoTo sWend
                End If
                If .Font.Scaling >= (MinScale + ChangeScale) Then
                    .Font.Scaling = .Font.Scaling - ChangeScale
                ElseIf .Font.SizeBi >= (MinSize + ChangeSize) Then .Font.SizeBi = .Font.SizeBi - ChangeSize
                Else: objPara.Range.Select: MsgBox "&#1500;&#1488; &#1492;&#1510;&#1500;&#1497;&#1495; &#1500;&#1491;&#1495;&#1493;&#1505; &#1508;&#1497;&#1505;&#1511;&#1488; &#1494;&#1493; &#1500;&#1514;&#1493;&#1498; &#1513;&#1493;&#1512;&#1492; &#1488;&#1495;&#1514;": Exit Sub
                End If
sWend:
            Wend
        End With
sNext:
    Next objPara
End Sub[/LEFT]

תורף המאקרא בנוי על המאקרא הנמצא כאן: http://word.tips.net/Pages/T001415_Finding_Long_Lines.html
אלא שעבר שינויים והוספות בכדי: להתאימו גם לטבלאות; כמו כן הגבלת פעולתו, עד כמה יקטין ויצר בכדי להתאים הפיסקא לשורה אחת וכו'; ועוד כמה פיטשיווקעס.

ות"ח לקרש שי' על עזרתו בכל זה.

 

[tkh]

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

דרך אגב - האם יש כאלו אתרים כמו ה-WORD_TIPS גם בעברית? אולי מישהו יודע?

 

[לייזער]

א. רשום מלכתחילה במאקרא שהוא יפעול רק על הנבחר. באם אתה רוצה שהמאקרא יעבור על כל המסמך (מבלי שתצטרך לבחו&#1512, תחליף (בשורה החמישי&#1514 מ-Selection ל-ActiveDocument. אלא שאז - כל עת שתפעיל את המאקרא זה ירוץ על כל המסמך מראשיתו. (באם רוצה הנך שיעבור על המסמך רק ממקום הסמן עד לסיום המסמך - יהי' צורך בהוספת עוד כמה שורות למאקרא. באם זה נחוץ - בטח תודי&#1506.

ב. המאקרא בודק דבר ראשון, וכן בין כל שלב ושלב (כדלקמ&#1503, האם עדיין ישנו ב' שורות לפיסקא הנוכחית (מבלי שימדוד את אורך התיבות שבטבלא. אתה צריך דוקא למדידה זו?).
באם התשובה היא כן - הרי הפעולות לפניך:
1) מחיל על הפיסקא את ההצרה (100) וגודל ברירת מחדל (6.5) - באם אחד מהגדרות הנ"ל היו מחוץ לטווח כלפי מעלה (או שהיו ב' הגדרות אחרות בהצרה\גודל גופא, שגורם לשדה ריק..).
--- בודק באם זה עדיין ב' שורות.
2) נסיון הצרה - מוריד ב5 אחוז בכל נסיון, עד ל85 אחוז.
--- בודק (בין כל נסיו&#1503 באם זה עדיין ב' שורות.
3) נסיון הקטנה - מוריד בחצי הפונקט בכל נסיון, עד לגודל 6 (במקרה דנן - נתת לו רק אפשרות הקטנה אחת... מ6.5 ל6).
--- בודק (בין 'כל' נסיו&#1503 באם זה עדיין ב' שורות.
4) באם כל הנ"ל אינו מועיל - אז בוחר הוא את הפיסקא שלא הצליח (מבטל בזה את הבחירה הקודמ&#1514, וצץ לך הודעה שלא הצליח.

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

 

[לייזער]

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

[LEFT]Sub ParaForceOneLine()
    Dim objPara As Paragraph, i As Integer[COLOR="Red"], myRange As Range[/COLOR]
    Const DefaultScale = 100, DefaultSize = 6.5
    Const MinScale = 85, MinSize = 6
    Const ChangeScale = 5, ChangeSize = 0.5
    
[COLOR="red"]    If Len(Selection.Range) = 0 Then
        Set myRange = ActiveDocument.Range(Start:=Selection.Range.Start, _
        End:=ActiveDocument.Content.End)
    Else: Set myRange = Selection.Range: End If[/COLOR]
    
    For Each objPara In [COLOR="red"]myRange[/COLOR].Paragraphs
        With objPara.Range
            If Len(objPara.Range) <= 2 Then GoTo sNext
            If .Information(wdWithInTable) Then i = 2 Else i = 0
            While .Information(wdFirstCharacterLineNumber) <> _
                .Characters(Len(.Text) - i).Information(wdFirstCharacterLineNumber)
                If .Font.Scaling > DefaultScale Or .Font.SizeBi > DefaultSize Then
                    .Font.Scaling = DefaultScale: .Font.SizeBi = DefaultSize: GoTo sWend
                End If
                If .Font.Scaling >= (MinScale + ChangeScale) Then
                    .Font.Scaling = .Font.Scaling - ChangeScale
                ElseIf .Font.SizeBi >= (MinSize + ChangeSize) Then .Font.SizeBi = .Font.SizeBi - ChangeSize
                Else: objPara.Range.Select: MsgBox "לא הצליח לדחוס פיסקא זו לתוך שורה אחת": Exit Sub
                End If
sWend:
            Wend
        End With
sNext:
    Next objPara
End Sub[/LEFT]

 

[אברימי]

אני מתפעל מהרמה, של ההבנה, המחשבה, הנכונות והסיוע!
מרבים זכויות!

 

[tkh]

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