שיתוף | אינצקלופדיה שיתופית עבור קודים של מאקרו - איך עושים את....
-
אינצקלופדיה שיתופית למאקרו (VBA)
פוסט זה נועד כדי לשתף קטעי קוד מוצלחים עבור פונקציות שונות במאקרו (VBA) עבור תוכנת מיקרוסופט וורד.
הציבור מוזמן לשתף
נ.ב. אינני מתכנן לענות על שאלות רק להעלות קטעי קוד שימושיים- קוד לסימון המילה הראשונה בפיסקה בכל המסמך
- קוד להוספת צורה במיקום הנוכחי של הסמן במסמך
- איך לעשות פעולות נסתרות מעיני המשתמש - ולהגביר את מהירות הקוד
- קוד להתקנת תבנית בתוך תיקיית ההתחלה של וורד
- קוד ליצירת לולאה - עד מילוי תנאי מסויים
- קוד להוספת סגנון והסרתו
- לולאה שחוזרת על עצמה מספר פעמים קצוב
- טיפול בשגיאות
- אינטראקציה עם המשתמש בצורה יעילה - כן, לא, או ביטול. (יצירת תנאים לפי בחירת המשתמש).
- איך לשנות את תחום הטקסט המסומן
11.קוד לפתיחת מסמך קובץ תיקייה או אתר אינטרנט
12. קוד עיצוב פיסקה כנהוג בספרי קודש, חלון, מילה ראשונה, ומרכוז שורה אחרונה
13. הגדלה והקטנה בחצי נקודה על טקסט נבחר
14. כותרות צד
15.כמה מוסכמויות בכתיבת קוד:
16. מה עושים כאשר הטקסט בתוך userform לא מופיע
17.חיפוש והחלפה במסמכים מרובים
18. פתיחת מסמכים מרובים
19. הכנסת טקסט נבחר (כגון מראה מקום) לתוך סוגריים.
20.הערות ברצף ו - הסרת הערות ברצף
21. הקטנת והגדלת סוגריים
22. איך ליצור userform - מדריך
23.הגדל רווחים בין מילים
23.הסרת כל הרווחים בטקסט שסומן
24. איך ליצור range נפרד עבור כל טור בהערות שוליים
25. שינוי מרווח בין טורים רק בהערות שוליים
26. קוד חמוד להעתקת כל המודולים מתבנית אחת לשניה
עריכה נוכחית:
27. קוד לשינוי שפת המקלדת לעברית
28. קוד לייצוא שמות הקבצים מתוך תיקייהמושגי יסוד בVBA
נא לא לשאול שאלות
-
אני לא הולך להסביר פה איך ליצור מודול ולפתוח את הvba לזה תעשו שיעורי בית לבד.
-
כל קוד חייב להיות בתוך sub עם שם
-
בניית מאקרו הוא בעצם במו בניית פאזל, לפאזל הזה יש שלושה סוגי חלקים: אובייקטים הגדרות ופעולות.
אובייקטים הם חלקי המסמך כגון פיסקאות וכו'. הגדרות הם הגדרות הפיסקה או הגופן וכו'. ופעולות הם פעולות שנעשה עם האובייקט כגון להעתיק אותו.
דוגמא: selection.delete זוהי פעולה מחיקה על הטקסט המסומן
"Selection.font.Name = "Arial זוהי פעולה שמגדירה את שם הפונט של הטקסט המסומן ל- Arial
פעולות באות אחרי נקודה. מאפיינים באים אחרי = -
הגדרת משתנים כמה כללים טובים:
שם המשתנה חייב להתחיל באות
אין להוסיף רווחים לשם המשתנה
אין לתת למשתנה שם זהה לשם המאקרו
אין לתת למשתנים שמות שמורים כגון Save
מומלץ לתת שם המתאר באופן מדויק את משמעות המשתנה -
משתנה מוגדר על ידי Dim "שם המשתנה" As "סוג המשתנה"
לדוגמא Dim MyString As String משתנה בשם MyString שהוגדר כמחרוזת טקסט -
סוגי משתנים
Integer - מאפשר לאחסן בתוכו מספרים שלמים
long - כמו integer רק עבור מספרים גדולים מ32,000
Double - מאפשר לאחסן בתוכו מספרים עשרוניים
String - מאפשר לאחסן בתוכו מחרוזת טקסט
Range - מאפשר לאחסן בתוכו טווחים
כמו"כ כל אובייקט במסמך יכול להיות משתנה ג"כ -
אחרי Dim - הכרזה של המשתנה יש לתת לו ערך
לדוגמא
Dim Mystring As String
"Mystring = "abc
הערה הזנה של טקסט צמיד תהיה בתוך מירכאות משא"כ במספרים.
בקביעת משתני טווח יש להוסיף את המילה set
לדוגמא
Dim myrange As Range
Set myrange = Selection.range
המשתנה של הטווח הוגדר כטווח הטקסט המסומן
-
@pcinfogmach
קטע קוד לסימון המילה הראשונה בפיסקה בכל המסמך - יש הרבה צורות לעשות את זה, למעשה הקטע דלהלן חוסך הרבה בעיות שיופיעו בצורות השונות: כגון כפילויות ועוד...קטע קוד זה איננו עושה כלום רק מסמן - כל פעולה שתירצו לעשות על המילה הראשונה יש להוסיףמיד אחרי סימון המילה הראשונה
paraRange.Select
כדי להריץ את הקוד רק על פיסקאות שסומנו ולא על כל המסמך
יש לשנות אתFor Each para In ActiveDocument.Paragraphs
ל-For Each para In Selection.Range.Paragraphs
Sub סימון_המילה_הראשונה_בפיסקה_בכל_המסמך() 'יצירת משתנים Dim para As Paragraph Dim paraText As String Dim firstSpace As Long Dim paraRange As Range 'יצירת לולאה For Each para In ActiveDocument.Paragraphs 'החרגה של פיסקאות עם שורה אחת ופיסקאות עם יישור למרכז If para.Range.ComputeStatistics(wdStatisticLines) > 1 And para.Range.ParagraphFormat.Alignment <> wdAlignParagraphCenter Then 'הגדרת המשתנים paraText = para.Range.Text firstSpace = InStr(1, paraText, " ") If firstSpace > 0 Then Set paraRange = para.Range paraRange.End = paraRange.Start + firstSpace 'סימון המילה הראשונה paraRange.Select End If End If Next para End Sub
כדי לסמן יותר ממילה אחת בראש הפיסקה לפי בחירת המשתמש השתמשו בקוד זה:
Sub SelectWords() ' Declare variables Dim para As Paragraph Dim paraText As String Dim numSpaces As Integer Dim spacePos As Long Dim startSel As Long Dim endSel As Long Dim i As Integer Dim paraRange As Range ' Get number of spaces from user input numSpaces = InputBox("Enter the number of spaces to select", "Select Words", 1) ' Loop through selected paragraphs For Each para In ActiveDocument.Paragraphs ' Check if paragraph meets criteria If para.Range.ComputeStatistics(wdStatisticLines) > 1 And para.Range.ParagraphFormat.Alignment <> wdAlignParagraphCenter Then ' Get text of paragraph paraText = para.Range.Text ' Find position of first space spacePos = InStr(1, paraText, " ") ' Find position of selected space For i = 2 To numSpaces spacePos = InStr(spacePos + 1, paraText, " ") If spacePos = 0 Then Exit For Next i ' Select words If spacePos > 0 Then startSel = para.Range.Start endSel = startSel + spacePos - 1 Set paraRange = ActiveDocument.Range(Start:=startSel, End:=endSel) paraRange.Select End If End If Next para End Sub
-
קוד להוספת צורה במיקום הנוכחי במסמך -
הקוד גם נותן שם לצורה (
sq
) כך שיהיה אפשר להתייחס אליה בהמשך עם שם זה לדוגמאsq.Select
דהיינו סימון הצורה.msoShapeRectangle
זהו שם הצורה = ריבוע.
לרשימה של כל הצורות עיין כאןSub הוספת_צורה_במיקום_הנוכחי_במסמך() 'יצירת משתנים Dim sel As Range Dim topDist As Integer, leftDist As Integer Dim sq As Shape 'חישוב המיקום הנוכחי של סמן העכבר Set sel = Selection.Range topDist = sel.Information(wdVerticalPositionRelativeToPage) leftDist = sel.Information(wdHorizontalPositionRelativeToPage) 'הוספת ריבוע המספרים הם הגובה והרוחב של הצורה כמובן שאפשר לשנות אותם Set sq = doc.Shapes.AddShape(msoShapeRectangle, leftDist, topDist, 10, 10) End Sub
אפשר גם להחיל הגדרות עבור הצורה
לדוגמא היישור של הצורה לפני או מאחרי הטקסט או בשורה עם הטקסט וכו' עיין כאן לרשימה המלאה
דוגמא:sq.WrapFormat.Type = wdWrapInline
פקודות אלו יהפכו את הצורה ואת המילוי שלהלשקופים:
sq.Line.Visible = msoFalse
sq.Fill.Visible = msoFalse
פקודות אלו מגדירים את המרווח בין הצורה לטקסט:
sq.WrapFormat.DistanceTop = 0
sq.WrapFormat.DistanceBottom = 0
sq.WrapFormat.DistanceLeft = 0
sq.WrapFormat.DistanceRight = 0
פקודות אלו מגדירים את הצורה להתאים אוטומטית לתוכן הטקסט שבפנים"
sq.TextFrame.AutoSize = True sq.TextFrame.WordWrap = False sq.TextFrame.TextRange.ParagraphFormat.SpaceAfter = 0
-
איך לעשות פעולות נסתרות מעיני המשתמש: (לפעמים המאקרו הוא קצת בלגן לעיניים ועדיף להסתיר מעיני המשתמש מה קורה תוכ"ד הרצה).
כמו"כ הסתרת פעולת הקוד מגבירה את מהירות הרצתו'להוסיף לפני תחילת המאקרו Application.ScreenUpdating = False 'ואחרי סוף המאקרו Application.ScreenUpdating = true
-
@pcinfogmach
קוד להתקנת תבנית בתוך תיקיית ההתחלה של וורד
קרדיט ל - @NykUserאפשר גם להקצות למאקרו קיצור מקשים כמו שמופיע בספויילר
התקנה_אל_תיקיית_startup() Dim fs As Object Dim dirFile As String Set fs = CreateObject("Scripting.FileSystemObject") dirFile = Dir(Application.StartupPath & "\" & "Cross referece" & "*" & ".dot") If Len(dirFile) = 0 Then fs.CopyFile ActiveDocument.AttachedTemplate.FullName, Application.StartupPath & "\" & ActiveDocument.AttachedTemplate.Name If fs.FileExists(Application.StartupPath & "\" & ActiveDocument.AttachedTemplate) = True Then MsgBox " הותקן בהצלחה " & ActiveDocument.AttachedTemplate Else Dim A As String A = InputBox("העתק את " & ActiveDocument.AttachedTemplate & " לנתיב זה", "שגיאה בהתקנה", Application.StartupPath) End If Else MsgBox ActiveDocument.AttachedTemplate & " הקובץ כבר נמצא בתיקיית ההתקנה יש להסירו לפני התקנה חוזרת" Call Shell("explorer.exe" & " " & Application.StartupPath, vbNormalFocus) End If End Sub
-
קוד ליצירת לולאה - עד מילוי תנאי מסויים
Do 'הכנס פקודה Loop Until 'הכנס כאן תנאי להפסקת הלולאה
דוגמא שימושית: קוד להזזת הסמן עד שהטקסט כבר אינו טקסט עילי
Do Selection.Move Unit:=wdCharacter, Count:=1 Loop Until Selection.Font.Superscript = False
-
קוד להוספת סגנון והסרתו
'הוספת והסרת הסגנון Dim styl As style On Error Resume Next Set styl = ActiveDocument.Styles("הסגנון שלי") On Error GoTo 0 If styl Is Nothing Then 'יצירת הסגנון ActiveDocument.Styles.Add Name:="הסגנון שלי", _ Type:=WdStyleType.wdStyleTypeCharacter 'קביעת מיקום הסגנון בסרגל הסגנונות (מס' 3 - ניתן לשינוי) ActiveDocument.Styles("הסגנון שלי").Priority = 3 'הוספת הסגנון לסרגל הסגנונות ActiveDocument.Styles("הסגנון שלי").QuickStyle = True Else styl.Delete End If 'קוד לההחלת הסגנון על הטקסט המוסמן Selection.Range.style = "הסגנון שלי"
-
לולאה שחוזרת על עצמה מספר פעמים קצוב
בדוגמא דלהלן הלולאה חוזרת על עצמה 3 פעמיםDim i As Integer For i = 1 To 3 With para .Collapse: .MoveUntil cset:=" ": .MoveEnd: .Collapse Direction:=wdCollapseEnd .Select End With Next i
אפשר גם לתת למשתמש לבחור כמה פעמים תחזור הלולאה על עצמה
Dim iterations As Integer On Error Resume Next iterations = InputBox("כתבו במספרים כמה פעמים לחזור על הפקודה") On Error GoTo 0 For i = 1 To iterations With para .Collapse: .MoveUntil cset:=" ": .MoveEnd: .Collapse Direction:=wdCollapseEnd .Select End With Next i
-
לפעמים נוצר צורך שהמאקרו יתעלם משגיאות (לדוגמא: אם נותנים למשתמש להזין משהו והוא לא מזין כלום זה יוצר שגיאה)
לפני השורה הבעייתית יש להזין
On Error Resume Next
ולאחריה (כדי שלא ישאר פקד השגיאות כבוי)
On Error GoTo 0
-
אינטראקציה עם המשתמש בצורה יעילה - כן, לא, או ביטול. (יצירת תנאים לפי בחירת המשתמש)
Dim interaction As VbMsgBoxResult interaction = MsgBox("הזן כאן הוראות למשתמש", vbQuestion + vbYesNoCancel + vbMsgBoxRight + vbMsgBoxRtlReading, "הזן כאן כותרת") Select Case interaction Case vbCancel ' המשתמש לחץ על ביטול MsgBox "הפעולה בוטלה" exit sub Case vbYes ' המשתמש לחץ על כן 'הכניסו איזשהו קוד כאן Case vbNo ' המשתמש לחץ על לא 'הכניסו איזשהו קוד כאן End Select
אם ברצונכם לפצל את הקוד של תוצאות התגובות עשו זאת כך.
Dim interaction As VbMsgBoxResult interaction = MsgBox("הזן כאן הוראות למשתמש", vbQuestion + vbYesNoCancel + vbMsgBoxRight + vbMsgBoxRtlReading, "הזן כאן כותרת") if interaction = vbCancel then ' המשתמש לחץ על ביטול "הפעולה בוטלה" msgbox exit sub end if if interaction = vbYes then ' המשתמש לחץ על כן 'הכניסו איזשהו קוד כאן end if if interaction = vbNo then ' המשתמש לחץ על לא 'הכניסו איזשהו קוד כאן end if
כדי לפתוח חלונית מובנית של וורד ולתת למשתמש לבחור ביטול כדי לבטל את פעולת המאקרו הזינו קוד זה. (בדוגמא זו אנו משתמשים עם החלונית של עיצוב גופן - קודים עבור חלוניות נוספים אפשר לראות כאן)
If Dialogs(wdDialogFormatFont).Show = False Then Exit Sub
עדכון:
כדי להראות למשתמש הודעה במשך הרצת המאקרוApplication.StatusBar = "ההודעה שלי"
אפשר להפסיק את הצגת ההודעה על ידי הכנסתו ללואה
-
איך לשנות את תחום הטקסט המסומן
'הקטנת תחום הטקסט המוסמן ב -1 מהסוף Selection.MoveEnd wdCharacter, -1 'או With Selection.Range .End = .End - 1 .Select End With 'הגדלת תחום הטקסט המוסמן ב -1 מהסוף Selection.MoveEnd wdCharacter, 1 'או With Selection.Range .End = .End + 1 .Select End With 'הקטנת תחום הטקסט המוסמן ב -1 מההתחלה Selection.Movestart wdCharacter, 1 'או With Selection.Range .Start = .Start + 1 .Select End With 'הגדלת תחום הטקסט המוסמן ב -1 מההתחלה Selection.MoveEnd wdCharacter, -1 'או With Selection.Range .Start = .Start - 1 .Select End With 'העברת הסמן לפני הטקסט המסומן Selection.Collapse Direction:=wdCollapseStart 'העברת הסמן אחרי הטקסט המסומן Selection.Collapse Direction:=wdCollapseend
-
קוד לפתיחת מסמך קובץ תיקייה או אתר אינטרנט
רק צריך לוודא שהוא יהיה במודול בפני עצמו כדי למנוע בעיות ושלא יהיה מופע כפול של option Explicit
Option Explicit Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _ (ByVal hwnd As LongPtr, ByVal lpOperation As String, ByVal lpFile As String, _ ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As LongPtr Sub OpenWebPage() Dim url As String url = "הכנס כאן את כתובת האתר תיקייה או הקובץ באופן מלא" 'Replace with the URL of the webpage you want to open ShellExecute 0, "open", url, vbNullString, vbNullString, vbNormalFocus End Sub
-
קוד עיצוב פיסקה כנהוג בספרי קודש - מילה ראשונה, חלון, ומירכוז שורה אחרונה:
קרדיט ל- @NykUser @מאקרו ו-@pcinfogmachמצו"ב שני שיטות:
בשיטה הראשונה - עובד יותר חלק ומקצועי אבל כדי לערוך שינויים צריך להריץ שוב את המאקרו כדי לתקן את העיצוב.
בשיטה השניה - אפשר לערוך שינויים ללא בעיות.
יש בה שני חסרונות אומנם:
1.שהמירכוז שורה אחרונה הופך את הגדרות הטאבים שבמסמך ל-'0 '.
2.שבעיצוב חלון נוצר סטייה בגובה השורה בין המילה הראשונה לשורה הראשונה (אפשר לפתור זאת על ידי הגדרת רווח פיסקה - כולל החלון - כמדוייק באפשרויות פיסקה).
שיטה ראשונה:
חלון.bas
שורה_אחרונה.basSub עיצוב_מילה_ראשונה_לפי_סגנון() Dim myDialog As Dialog, para As Paragraph, rng As Range, styl As String styl = ActiveDocument.Styles(wdStyleStrong).NameLocal Set rng = Selection.Range Set myDialog = Dialogs(wdDialogFormatStyle) Selection.MoveUp Unit:=wdParagraph, Count:=1 With myDialog .Name = styl .Display End With For Each para In rng.Paragraphs With para.Range .End = .Start .MoveEndUntil " ", wdForward .Select End With myDialog.Execute Next para End Sub Sub עיצוב_מילה_ראשונה_ללא_סגנון() Dim myDialog As Dialog, para As Paragraph, rng As Range Set rng = Selection.Range Set myDialog = Dialogs(wdDialogFormatFont) myDialog.Display For Each para In rng.Paragraphs With para.Range .End = .Start .MoveEndUntil " ", wdForward .Select End With myDialog.Execute Next para End Sub Sub הסר_עיצוב_מילה_ראשונה() Dim para As Paragraph, rng, mrng As Range Set rng = Selection.Range For Each para In rng.Paragraphs With para.Range .Collapse: .MoveUntil cset:=" ": .MoveEnd: .Collapse Direction:=wdCollapseEnd .move Unit:=wdCharacter, Count:=1 .Select End With Selection.CopyFormat Selection.MoveUp Unit:=wdParagraph, Count:=1, Extend:=wdExtend Selection.PasteFormat Application.ScreenRefresh Next para End Sub
שיטה שניה:
Option Explicit ' ' ' 'עיצוב חלון על עיקרון מסגרת ' עיצוב מילה ראשונה על עיקרון של החלת סגנון ' עיצוב שורה אחרונה על עיקרון של שלמה מימות ממתמחים טופ ' Private Sub עיצוב_מהיר_כל_העיצובים() 'קביעת הטווח Dim slctd As Range Set slctd = Selection.Range slctd.SetRange Selection.Paragraphs.First.Range.Start, Selection.Paragraphs.Last.Range.End slctd.Select 'הוסף סימנים ומרכז שורה אחרונה Call part1(slctd) 'הוסף מעבר שורה עם סימנים לפני פיסקה ראשונה slctd.InsertBefore "$$$$$$$$$" & Chr(13) 'הכנות בשביל עיצוב מילה ראשונה או חלון Call part2(slctd) 'יצירת הסגנונות אם צריך Call part3A Call part3B 'החלת סגנון חלון Call part4A 'החלת סגנון בלי חלון עבור פסקאות עם פחות מארבע שורות Call part4c 'ניקוי שאריות Call part5 'msgbox תיקון הסטייה End Sub Private Sub עיצוב_מהיר_שורה_אחרונה_ומילה_ראשונה_בלי_חלון() 'קביעת הטווח Dim slctd As Range Set slctd = Selection.Range slctd.SetRange Selection.Paragraphs.First.Range.Start, Selection.Paragraphs.Last.Range.End 'הוסף סימנים ומרכז שורה אחרונה Call part1(slctd) 'הוסף מעבר שורה עם סימנים לפני פיסקה ראשונה slctd.InsertBefore "$$$$$$$$$" & Chr(13) 'הכנות בשביל עיצוב מילה ראשונה או חלון Call part2(slctd) 'יצירת הסגנונות אם צריך Call part3B 'החלת סגנון מילה ראשונה Call part4B 'החלת סגנון בלי חלון עבור פסקאות עם פחות מארבע שורות Call part4c 'ניקוי שאריות Call part5 End Sub Private Sub עיצוב_מהיר_הסר_את_כל_העיצובים() Call part6 Call הסר_מרכוז_שורה_אחרונה End Sub Private Sub עיצוב_מהיר_מילה_ראשונה_עם_חלון() 'קביעת הטווח Dim slctd As Range Set slctd = Selection.Range slctd.SetRange Selection.Paragraphs.First.Range.Start, Selection.Paragraphs.Last.Range.End 'הוסף סימנים Call part1B(slctd) 'הוסף מעבר שורה עם סימנים לפני פיסקה ראשונה slctd.InsertBefore "$$$$$$$$$" & Chr(13) 'הכנות בשביל עיצוב מילה ראשונה או חלון Call part2(slctd) 'יצירת הסגנונות אם צריך Call part3A Call part3B 'החלת סגנון חלון Call part4A 'החלת סגנון בלי חלון עבור פסקאות עם פחות מארבע שורות Call part4c 'ניקוי שאריות Call part5 End Sub Private Sub עיצוב_מהיר_מילה_ראשונה_בלי_חלון() 'קביעת הטווח Dim slctd As Range Set slctd = Selection.Range slctd.SetRange Selection.Paragraphs.First.Range.Start, Selection.Paragraphs.Last.Range.End 'הוסף סימנים Call part1B(slctd) 'הוסף מעבר שורה עם סימנים לפני פיסקה ראשונה slctd.InsertBefore "$$$$$$$$$" & Chr(13) 'הכנות בשביל עיצוב מילה ראשונה או חלון Call part2(slctd) 'יצירת הסגנונות אם צריך Call part3B 'החלת סגנון מילה ראשונה Call part4B 'החלת סגנון בלי חלון עבור פסקאות עם פחות מארבע שורות Call part4c 'ניקוי שאריות Call part5 End Sub Private Sub עיצוב_מהיר_מרכוז_שורה_אחרונה() 'קביעת הטווח Dim slctd As Range Set slctd = Selection.Range slctd.SetRange Selection.Paragraphs.First.Range.Start, Selection.Paragraphs.Last.Range.End 'הוסף סימנים ומרכז שורה אחרונה Call part1(slctd) Call part5 End Sub Private Sub הסר_מילה_ראשונה_וחלון() Call part6 End Sub Private Sub הסר_מרכוז_שורה_אחרונה() 'קביעת הטווח Dim slctd As Range Set slctd = Selection.Range slctd.SetRange Selection.Paragraphs.First.Range.Start, Selection.Paragraphs.Last.Range.End 'הוסף סימנים בפיסקאות שנבחרו slctd.Find.Execute _ FindText:="(*)(^t)(^13)", _ ReplaceWith:="\1+++++++\3", _ Forward:=True, Wrap:=wdFindStop, MatchWildcards:=True, _ Replace:=wdReplaceAll 'חפש והחלף לפי סימנים Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting With Selection.Find.Replacement.ParagraphFormat .SpaceBeforeAuto = False .SpaceAfterAuto = False .Alignment = wdAlignParagraphJustify End With With Selection.Find .Text = "(*)(+++++++)(^13)" .Replacement.Text = "\1\3" .Forward = True .Wrap = wdFindContinue .Format = True .MatchCase = False .MatchWholeWord = False .MatchKashida = False .MatchDiacritics = False .MatchAlefHamza = False .MatchControl = False .MatchAllWordForms = False .MatchSoundsLike = False .MatchWildcards = True End With Selection.Find.Execute Replace:=wdReplaceAll End Sub Sub part1(slctd As Range) ' Do something with slctd here ' 'מרכוז שורה אחרונה ' 'שינוי הטאבים ל- 0 Selection.ParagraphFormat.TabStops.ClearAll ActiveDocument.DefaultTabStop = CentimetersToPoints(0) 'החלת עיצוב שורה אחרונה Dim p As Paragraph For Each p In slctd.Paragraphs ' Check if paragraph contains more than one line If Not p.Range.ComputeStatistics(wdStatisticLines) > 1 Then p.Range.InsertBefore "$#$#$#" GoTo nxt End If p.Range.ParagraphFormat.Alignment = wdAlignParagraphDistribute p.Range.Characters.Last.Previous = vbTab If Not p.Range.ComputeStatistics(wdStatisticLines) > 2 _ Or Not p.Range.ComputeStatistics(wdStatisticLines) > 3 Then p.Range.InsertBefore "$#$#$#" End If nxt: Next p End Sub Sub part1B(slctd As Range) ' Do something with slctd here ' 'מרכוז שורה אחרונה ' 'שינוי הטאבים ל- 0 Selection.ParagraphFormat.TabStops.ClearAll ActiveDocument.DefaultTabStop = CentimetersToPoints(0) 'החלת עיצוב שורה אחרונה Dim p As Paragraph For Each p In slctd.Paragraphs ' Check if paragraph contains more than one line If Not p.Range.ComputeStatistics(wdStatisticLines) > 1 _ Or Not p.Range.ComputeStatistics(wdStatisticLines) > 2 _ Or Not p.Range.ComputeStatistics(wdStatisticLines) > 3 Then p.Range.InsertBefore "$#$#$#" End If Next p End Sub Private Sub part2(slctd As Range) ' 'הכנות בשביל עיצוב מילה ראשונה או חלון ' 'להוסיף פתרון בעיות עם סימני הערות שוליים צריך 'החלת סימן החרגה עבור פיסקאות מודגשות (כותרות) Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = "*^13" .Replacement.Text = "$$$$$$$$$^&" .Forward = True .Wrap = wdFindContinue .Format = True .Font.BoldBi = True .Font.Bold = True .MatchCase = False .MatchWholeWord = False .MatchKashida = False .MatchDiacritics = False .MatchAlefHamza = False .MatchControl = False .MatchAllWordForms = False .MatchSoundsLike = False .MatchWildcards = True End With Selection.Find.Execute Replace:=wdReplaceAll 'סימון המילה הראושנה והפרדתו מהפיסקה שאחריו (כדי שהסגנון יחול רק עליו ולא על כל הפיסקה 'אין אפשרות שיחול רק עליו בלי זה כי צריך להחיל עליו מסגרת 'אין בעיה במה שהואנפרד כי המסגרת מוגדרת לקבץ אותו יחד עם הפיסקה שאחריו slctd.Find.Execute FindText:="(^13)([!$]@ )", ReplaceWith:="\1^+^+^+^+\2^+^+^+^+^p", Forward:=True, Wrap:=wdFindStop, MatchWildcards:=True, Replace:=wdReplaceAll End Sub Private Sub part3A() Dim styl As Style ' 'יצירת סגנון מילה ראשונה עם חלון ' 'הוזזת הסמן לתחילת הטווח כדי למנוע עיצוב המילים המסומנות Selection.Collapse Direction:=wdCollapseStart 'בדיקה אם הסגנון כבר קיים On Error Resume Next Set styl = ActiveDocument.Styles("מילת פתיח עם חלון עיצוב מהיר") On Error GoTo 0 'הודעה למשתמש If Not styl Is Nothing Then Exit Sub Dim strt As VbMsgBoxResult strt = MsgBox("לפני שנחתחיל תצטרכו לבחור עיצוב נפרד עבור סגנון 'מילת פתיח עם חלון עיצוב מהיר'." & vbNewLine & "לאחר יצירת הסגנון תמיד תוכלו לשנותו על ידי לחיצה ימנית על הסגנון בסרגל הסגנונות." & vbNewLine & "כך או כך הלחצן יחיל את הסגנון המבוקש על המילה הראשונה שבכל פיסקה.", _ vbInformation + vbOKCancel + vbMsgBoxRight + vbMsgBoxRtlReading, "יצירת והחלת סגנון 'מילה ראשונה בהערות שוליים'") If strt = vbCancel Then Exit Sub 'בחירת העיצוב Selection.Font.Name = Selection.Font.Name With Dialogs(wdDialogFormatFont) .Update .Font = Selection.Font.Name .FontNameBi = Selection.Font.Name If .Show = False Then Exit Sub End With 'יצירת הסגנון ActiveDocument.Styles.Add Name:="מילת פתיח עם חלון עיצוב מהיר", Type:=WdStyleType.wdStyleTypeParagraph ActiveDocument.Styles("מילת פתיח עם חלון עיצוב מהיר").Priority = 3 ActiveDocument.Styles("מילת פתיח עם חלון עיצוב מהיר").QuickStyle = True 'הגדרת הסגנון כסגנון עם מסגרת With ActiveDocument.Styles("מילת פתיח עם חלון עיצוב מהיר").ParagraphFormat .Borders(wdBorderLeft).LineStyle = wdLineStyleNone .Borders(wdBorderRight).LineStyle = wdLineStyleNone .Borders(wdBorderTop).LineStyle = wdLineStyleNone .Borders(wdBorderBottom).LineStyle = wdLineStyleNone With .Borders .DistanceFromTop = 1 .DistanceFromLeft = 4 .DistanceFromBottom = 1 .DistanceFromRight = 4 .Shadow = False End With End With 'הגדרות המסגרת With ActiveDocument.Styles("מילת פתיח עם חלון עיצוב מהיר").Frame .TextWrap = True .WidthRule = wdFrameAuto .HeightRule = wdFrameAuto .HorizontalPosition = wdFrameRight .RelativeHorizontalPosition = wdRelativeHorizontalPositionColumn .RelativeVerticalPosition = wdRelativeVerticalPositionParagraph .HorizontalDistanceFromText = CentimetersToPoints(0.13) .VerticalDistanceFromText = CentimetersToPoints(0) .LockAnchor = False End With End Sub Private Sub part3B() Dim styl As Style ' 'יצירת סגנון מילה ראשונה בלי חלון ' 'הוזזת הסמן לתחילת הטווח כדי למנוע עיצוב המילים המסומנות Selection.Collapse Direction:=wdCollapseStart 'בדיקה אם הסגנון כבר קיים On Error Resume Next Set styl = ActiveDocument.Styles("מילת פתיח בלי חלון עיצוב מהיר") On Error GoTo 0 'הודעה למשתמש If Not styl Is Nothing Then Exit Sub Dim strt As VbMsgBoxResult strt = MsgBox("לפני שנחתחיל תצטרכו לבחור עיצוב נפרד עבור סגנון 'מילת פתיח בלי חלון עיצוב מהיר'." & vbNewLine & "לאחר יצירת הסגנון תמיד תוכלו לשנותו על ידי לחיצה ימנית על הסגנון בסרגל הסגנונות." & vbNewLine & "כך או כך הלחצן יחיל את הסגנון המבוקש על המילה הראשונה שבכל פיסקה.", _ vbInformation + vbOKCancel + vbMsgBoxRight + vbMsgBoxRtlReading, "יצירת והחלת סגנון 'מילה ראשונה בהערות שוליים'") If strt = vbCancel Then Exit Sub 'בחירת העיצוב Selection.Font.Name = Selection.Font.Name With Dialogs(wdDialogFormatFont) .Update .Font = Selection.Font.Name .FontNameBi = Selection.Font.Name If .Show = False Then Exit Sub End With 'יצירת הסגנון ActiveDocument.Styles.Add Name:="מילת פתיח בלי חלון עיצוב מהיר", Type:=WdStyleType.wdStyleTypeCharacter ActiveDocument.Styles("מילת פתיח בלי חלון עיצוב מהיר").Priority = 3 ActiveDocument.Styles("מילת פתיח בלי חלון עיצוב מהיר").QuickStyle = True End Sub Private Sub part4A() ' 'החלת סגנון מילה ראשונה כולל מסגרת ' Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting Application.ScreenRefresh Selection.Find.Replacement.Style = ActiveDocument.Styles("מילת פתיח עם חלון עיצוב מהיר") With Selection.Find .Text = "(^+^+^+^+)(*)(^+^+^+^+)" .Replacement.Text = "\2" .Forward = True .Wrap = wdFindContinue .Format = True .MatchCase = False .MatchWholeWord = False .MatchKashida = False .MatchDiacritics = False .MatchAlefHamza = False .MatchControl = False .MatchAllWordForms = False .MatchSoundsLike = False .MatchWildcards = True End With Selection.Find.Execute Replace:=wdReplaceAll End Sub Private Sub part4B() ' 'החלת סגנון מילה ראשונה בלי מסגרת ' Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting Application.ScreenRefresh Selection.Find.Replacement.Style = ActiveDocument.Styles("מילת פתיח בלי חלון עיצוב מהיר") With Selection.Find .Text = "(^+^+^+^+)(*)(^+^+^+^+)(^13)" .Replacement.Text = "\2" .Forward = True .Wrap = wdFindContinue .Format = True .MatchCase = False .MatchWholeWord = False .MatchKashida = False .MatchDiacritics = False .MatchAlefHamza = False .MatchControl = False .MatchAllWordForms = False .MatchSoundsLike = False .MatchWildcards = True End With Selection.Find.Execute Replace:=wdReplaceAll End Sub Private Sub part4c() ' 'בפסקאות עם פחות מארבע שורות החלת סגנון מילה ראשונה לא כולל מסגרת ' Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting Selection.Find.Replacement.Style = ActiveDocument.Styles( _ "מילת פתיח בלי חלון עיצוב מהיר") With Selection.Find .Text = "(^13)($#$#$#)(* )" .Replacement.Text = "\1\3" .Forward = True .Wrap = wdFindContinue .Format = True .MatchCase = False .MatchWholeWord = False .MatchKashida = False .MatchDiacritics = False .MatchAlefHamza = False .MatchControl = False .MatchAllWordForms = False .MatchSoundsLike = False .MatchWildcards = True End With Selection.Find.Execute Replace:=wdReplaceAll End Sub Private Sub part5() ' 'ניקוי הסימנים ' Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = "$$$$$$$$$" & Chr(13) .Replacement.Text = "" .Forward = True .Wrap = wdFindContinue .Format = False .MatchCase = False .MatchWholeWord = False .MatchKashida = False .MatchDiacritics = False .MatchAlefHamza = False .MatchControl = False .MatchAllWordForms = False .MatchSoundsLike = False .MatchWildcards = True End With Selection.Find.Execute Replace:=wdReplaceAll Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = "$$$$$$$$$" .Replacement.Text = "" .Forward = True .Wrap = wdFindContinue .Format = False .MatchCase = False .MatchWholeWord = False .MatchKashida = False .MatchDiacritics = False .MatchAlefHamza = False .MatchControl = False .MatchAllWordForms = False .MatchSoundsLike = False .MatchWildcards = True End With Selection.Find.Execute Replace:=wdReplaceAll Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = "$#$#$#" .Replacement.Text = "" .Forward = True .Wrap = wdFindContinue .Format = False .MatchCase = False .MatchWholeWord = False .MatchKashida = False .MatchDiacritics = False .MatchAlefHamza = False .MatchControl = False .MatchAllWordForms = False .MatchSoundsLike = False .MatchWildcards = True End With Selection.Find.Execute Replace:=wdReplaceAll End Sub Sub part6() ' 'הסרת עיצוב מילה ראשונה בפסקאות שנבחרו 'מאת pcinfogmach ' ' Declare variables Dim para As Paragraph, paraText As String, numSpaces, i As Integer, _ spacePos, startSel, endSel As Long, paraRange, slctd As Range, _ myFrame As Frame, myRange As Range ' Get number of spaces numSpaces = 1 Set slctd = Selection.Range slctd.SetRange Selection.Paragraphs.First.Range.Start, Selection.Paragraphs.Last.Range.End 'תחילת הלולאה For Each para In slctd.Paragraphs ' Check if paragraph meets criteria If para.Range.Style Like "כותרת*" Then GoTo nxt If para.Range.Style Like "Heading*" Then GoTo nxt If Not para.Range.ParagraphFormat.Alignment <> wdAlignParagraphCenter Then GoTo nxt ' Get text of paragraph paraText = para.Range.Text ' Find position of first space spacePos = InStr(1, paraText, " ") ' Find position of selected space For i = 2 To numSpaces spacePos = InStr(spacePos + 1, paraText, " ") If spacePos = 0 Then Exit For Next i ' Select words If Not spacePos > 0 Then GoTo nxt startSel = para.Range.Start endSel = startSel + spacePos Selection.SetRange Start:=startSel, End:=endSel Selection.Move Unit:=wdCharacter, Count:=1 Selection.End = Selection.End + 1 Selection.CopyFormat Selection.SetRange Start:=startSel, End:=endSel Selection.PasteFormat Selection.Start = Selection.Start - 3 For Each myFrame In Selection.Frames Set myRange = myFrame.Range myRange.Select Selection.PasteFormat myFrame.Delete myRange.Collapse wdCollapseEnd myRange.Delete wdCharacter, 1 Next myFrame Application.ScreenRefresh nxt: Next para ' ''מניעת שגיאות Application.ScreenRefresh End Sub
-
@pcinfogmach
הגדלה / הקטנה בחצי נקודה על טקסט נבחר. -רק כאשר הבחירה באותו גודל, וכאן המקום לבקש מי שיודע כיצד ניתן שהפונקציה תעבוד גם על מספר גדלים תע"ב אם ישתף את הציבור.Sub הגדלה_בחצי_נקודה() Selection.Font.SizeBi = Selection.Font.SizeBi + 0.5 End Sub Sub הקטנה_בחצי_נקודה() Selection.Font.SizeBi = Selection.Font.SizeBi - 0.5 End Sub
-
קוד להוספת כותרות צד
Option Explicit Sub כותרות_צד() Dim numColumns As Integer, currentPara As Paragraph, slctd As Range _ 'set range Set slctd = Selection.Range 'start loop For Each currentPara In slctd.Paragraphs Application.ScreenUpdating = False currentPara.Range.Select 'get column width numColumns = ActiveDocument.PageSetup.TextColumns.Count If numColumns = 2 Then Dim columnWidth As Single Dim columnWidth2 As Single columnWidth = ActiveDocument.PageSetup.TextColumns.Item(1).Width columnWidth2 = ActiveDocument.PageSetup.TextColumns.Item(2).Width End If 'exceptions If Not currentPara.Range.ComputeStatistics(wdStatisticLines) > 1 _ Or Not currentPara.Range.ComputeStatistics(wdStatisticLines) > 2 Then GoTo nxt 'Get the first sentence of the current paragraph Dim firstSentence As String Dim words() As String words = Split(currentPara.Range.Text, " ") firstSentence = words(0) & " " & words(1) & " " & words(2) & " " _ & words(3) & " " & words(4) & " " & words(5) 'get font size set box font size and calc misalignment adjustment accordingly Dim fontSize, x, y, z As Single fontSize = currentPara.Range.Font.SizeBi - 4 x = currentPara.Range.Font.SizeBi y = x - 8 z = y * 0.4 'MsgBox z ' 'Dim spaceWidth As Double 'spaceWidth = currentPara.Range.font.spacing 'Dim spaceWidth As Double 'spaceWidth = ActiveDocument.PageSetup.TextColumns.spacing / 2 ' 'get middle of page Dim mrgn As Double mrgn = ActiveDocument.PageSetup.LeftMargin / 2 Dim newShape As Shape 'left column - if para calc is smaller then middle of page If ActiveDocument.PageSetup.PageWidth / 2 > currentPara.Range.Information(wdHorizontalPositionRelativeToPage) Then Set newShape = ActiveDocument.Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, _ Left:=currentPara.Range.Information(wdHorizontalPositionRelativeToPage) - columnWidth2 - mrgn, _ Top:=currentPara.Range.Information(wdVerticalPositionRelativeToPage), _ Width:=mrgn, Height:=50) newShape.TextFrame.TextRange.ParagraphFormat.Alignment = wdAlignParagraphRight End If 'right column - if para calc is larger If ActiveDocument.PageSetup.PageWidth / 2 < currentPara.Range.Information(wdHorizontalPositionRelativeToPage) Then Set newShape = ActiveDocument.Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, _ Left:=currentPara.Range.Information(wdHorizontalPositionRelativeToPage), _ Top:=currentPara.Range.Information(wdVerticalPositionRelativeToPage), _ Width:=mrgn, Height:=50) newShape.TextFrame.TextRange.ParagraphFormat.Alignment = wdAlignParagraphLeft End If 'newShape.TextFrame.MarginLeft = 0 'newShape.TextFrame.MarginRight = 0 newShape.TextFrame.MarginTop = z 'adjust misalignment newShape.TextFrame.MarginBottom = 0 newShape.Line.Visible = msoFalse newShape.TextFrame.TextRange.Text = firstSentence newShape.TextFrame.TextRange.Font.SizeBi = 8 newShape.TextFrame.AutoSize = True 'tiny adjustment If ActiveDocument.PageSetup.PageWidth / 2 > currentPara.Range.Information(wdHorizontalPositionRelativeToPage) Then newShape.TextFrame.MarginTop = newShape.TextFrame.MarginTop - 0.1 Else newShape.TextFrame.MarginTop = newShape.TextFrame.MarginTop - 0.05 newShape.TextFrame.MarginLeft = newShape.TextFrame.MarginLeft + 0.04 End If nxt: Application.ScreenUpdating = True Application.ScreenRefresh Next currentPara End Sub Sub מחק_כותרת_צד_בכל_המסמך() Dim shp As Shape, i As Integer, shppos, mrgnright, mrgnleft As Single mrgnleft = ActiveDocument.PageSetup.LeftMargin mrgnright = ActiveDocument.PageSetup.PageWidth - mrgnleft For i = ActiveDocument.Shapes.Count To 1 Step -1 Set shp = ActiveDocument.Shapes(i) shppos = shp.TextFrame.TextRange.Information(wdHorizontalPositionRelativeToPage) If shppos > mrgnright Or shppos < mrgnleft _ And shp.Type = msoTextBox And shp.Line.Visible = msoFalse Then 'And shp.Width = ActiveDocument.PageSetup.LeftMargin / 2 Then shp.Delete End If Next i End Sub Sub מחק_כותרות_צד_בעמוד_זה() Dim shp As Shape, i, currentPage As Integer, _ shppos, mrgnright, mrgnleft As Single mrgnleft = ActiveDocument.PageSetup.LeftMargin mrgnright = ActiveDocument.PageSetup.PageWidth - mrgnleft currentPage = Selection.Information(wdActiveEndPageNumber) Application.ScreenUpdating = False For Each shp In ActiveDocument.Shapes shppos = shp.TextFrame.TextRange.Information(wdHorizontalPositionRelativeToPage) If shp.Anchor.Information(wdActiveEndPageNumber) = currentPage And _ shppos > mrgnright Or shppos < mrgnleft _ And shp.Type = msoTextBox And shp.Line.Visible = msoFalse _ And shp.Anchor.Information(wdActiveEndPageNumber) = currentPage Then shp.Select (False) End If Next shp Application.ScreenUpdating = True Selection.Delete Unit:=wdCharacter, Count:=1 End Sub
-
@דאנציג כתב בשיתוף | אינצקלופדיה שיתופית עבור קודים של מאקרו - איך עושים את....:
וכאן המקום לבקש מי שיודע כיצד ניתן שהפונקציה תעבוד גם על מספר גדלים תע"ב אם ישתף את הציבור.
שתי אפשרויות:
א. לעשות לולאה שעוברת על כל התווים, המעלה שהכל יהיה במידה מדוייקת, החסרון שהפעולה תהיה מאד איטית בטקסט ארוך.
ב. להגדיר את הכל לפי התו הראשון בבחירה, המעלה שפועל בצורה מהירה, החסרון שההגדלה לא תהיה מדוייקת וזה רק נותן פתרון שלא יחזיר שגיאה.
אפשר לעשות ג"כ בדיקה האם מחזיר שגיאה ואז שיעבוד בלולאה... -
@OdedDvir כתב באקסס למתחילים: יצירת מערכת לניהול תורמים:
כמה מוסכמויות בכתיבת קוד:עבור שמות פונקציות יש להשתמש ב upper camel case, או בתרגום חופשי: כתיבת גמל (?) או כתיבה גמלונית(?) , דהיינו להתחיל כל מילה בשם הפונקציה באות גדולה, למשל:
()GetUserName
או
()CleanMyDeskעבור שמות משתנים או שמות פרמטרים (לפונקציה) על ידי lower camel case דהיינו להתחיל כל מילה באות גדולה, למעט המילה הראשונה בשם המשתנה, שמתחילה באות קטנה, למשל:
donationsToUpdate
או
MakeMeSomeCoffee(addSugar As Boolean, numberOfCups As Long)למרות ש-VBA לא תמיד שומרת על מוסכמויות אלו בעצמה (נו נו נו VBA...), כדאי להתרגל בהן כבר מתחילת הדרך. הדבר ישתלם בהמשך, כשנלמד עוד מוסכמויות או נרצה לעבור לשפה אחרת.
-
לפעמים כאשר משתמשים בuserform בתצורה של modeless הטקסט שבתוך ה userform לא נראה בהרצה במקרה כזה יש לקרוא לuserform כך:
Userform1.Show
Userform1.Repaint -
פוסט זה נמחק!