שיתוף | אינצקלופדיה שיתופית עבור קודים של מאקרו - איך עושים את....

[pcinfogmach]

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

Option Explicit
Sub הגדל_רווחים_בין_מילים()
    Dim rng, para, spaceRange As Range, i As Integer
    
    Set rng = Selection.Range
    
    'loop throgh pragraphs
    For i = 1 To rng.Paragraphs.Count
    Set para = rng.Paragraphs(i).Range
    Set spaceRange = para.Duplicate
    
    ' Loop through each space in the selected paragraph
    Do While spaceRange.InRange(para)
        spaceRange.MoveStartUntil " " ' Move to the next space
            If spaceRange.InRange(para) Then _
                spaceRange.Characters(1).Font.Spacing = spaceRange.Characters(1).Font.Spacing + 1
                   spaceRange.MoveStart unit:=wdCharacter, Count:=1 ' Move to the next character
    Loop
    
    Next i
    
End Sub


Sub הקטן_רווחים_בין_מילים()
    Dim rng, para, spaceRange As Range, i As Integer
    
    Set rng = Selection.Range
    
    'loop throgh pragraphs
    For i = 1 To rng.Paragraphs.Count
    Set para = rng.Paragraphs(i).Range
    Set spaceRange = para.Duplicate
    
    ' Loop through each space in the selected paragraph
    Do While spaceRange.InRange(para)
        spaceRange.MoveStartUntil " " ' Move to the next space
            If spaceRange.InRange(para) Then _
                spaceRange.Characters(1).Font.Spacing = spaceRange.Characters(1).Font.Spacing - 1
                   spaceRange.MoveStart unit:=wdCharacter, Count:=1 ' Move to the next character
    Loop
    
    Next i
    
End Sub

עריכה 3:
והנה קוד בשיטה אחרת לפי ההצעה של @menajemmendel קוד זה נערך על ידי ושופץ בעזרת @מאקרו

Sub ChangeSpacing()
Dim myrange As Range, orange As Range
Set myrange = Selection.Range
myrange.SetRange Selection.Paragraphs.First.Range.Start, Selection.Paragraphs.Last.Range.End
Set orange = ActiveDocument.Range(myrange.Start, myrange.End)

With orange
.Collapse
.MoveUntil cset:=" "
.SetRange Start:=.Start, End:=.Start + 1
.Select
End With

Dim c As Font, rslt As Integer
Set c = Selection.Font
rslt = c.Spacing + 1

With myrange.Find
.ClearFormatting
.Replacement.ClearFormatting
.Replacement.Font.Spacing = rslt
.Text = " "
.Replacement.Text = "^&"
.Forward = False
.Wrap = wdFindStop
.Format = True
End With
myrange.Find.Execute Replace:=wdReplaceAll
End Sub

[pcinfogmach]

הסרת כל הרווחים בטקסט שסומן

Sub DeleteSpacesInParagraph()
    Dim rng As Range
    
    ' Set the range to the current paragraph
    Set rng = Selection.Range
    
    ' Remove all spaces
    rng.text = Replace(rng.text, " ", "")
    
End Sub

[menajemmendel]

@pcinfogmach למה בלופ, מה רע לך בחפש והחלף? וכי הוא לא יותר מהיר?

[pcinfogmach]

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

[מאקרו]

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

[pcinfogmach]

@menajemmendel כתב בשיתוף | אינצקלופדיה שיתופית עבור קודים של מאקרו - איך עושים את....:

@pcinfogmach למה בלופ, מה רע לך בחפש והחלף? וכי הוא לא יותר מהיר?

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

[menajemmendel]

@pcinfogmach כתב בשיתוף | אינצקלופדיה שיתופית עבור קודים של מאקרו - איך עושים את....:

@menajemmendel כתב בשיתוף | אינצקלופדיה שיתופית עבור קודים של מאקרו - איך עושים את....:

@pcinfogmach למה בלופ, מה רע לך בחפש והחלף? וכי הוא לא יותר מהיר?

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

מה אתה מתכוןן? קודם מגדירים שההבחירה יהיה RANGE ואחר כן
במקום

Selection.Find

עושים

myrange.Find

ואז אתה יכול לחפש מה שאתה רוצה כרגיל,

[pcinfogmach]

פוסט זה נמחק!

[pcinfogmach]

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

Sub טורים()

'נתוני עמוד
Dim currpagenum, pg2num As Long
Dim currPageRange As Range

If ActiveWindow.View.SeekView = wdSeekFootnotes Then ActiveWindow.View.SeekView = wdSeekMainDocument

currpagenum = Selection.Information(wdActiveEndPageNumber)
Set currPageRange = ActiveDocument.Bookmarks("\page").Range

'נתוני הערות שוליים
Dim ftnoteclmn1 As Range
Dim ftnoteclmn2 As Range
Dim i As Integer, lastftnote As Integer
Dim ftnote As footnote

'הגדר את תחילת הטור הראשון בהערות שוליים
ActiveWindow.View.SeekView = wdSeekFootnotes
Set ftnoteclmn1 = Selection.Range

'מצא את המעבר בין הטורים על ידי לולאה
lastftnote = currPageRange.Footnotes.Count
For i = 1 To lastftnote
        Set ftnote = currPageRange.Footnotes(i)
        If ftnote.Range.Information(wdHorizontalPositionRelativeToPage) < ActiveDocument.PageSetup.pageWidth / 2 Then
            ftnote.Range.Select
            Selection.HomeKey Unit:=wdLine
                
            Do While Selection.Information(wdHorizontalPositionRelativeToPage) < ActiveDocument.PageSetup.pageWidth / 2
                Selection.MoveLeft Unit:=wdWord, Count:=1
            Loop
            Selection.MoveRight Unit:=wdWord, Count:=1
            Exit For
        End If
    Next
    
'הגדר את סוף הטור הראשון 
ftnoteclmn1.End = Selection.Range.Start

'הגדר את תחילת הטור השני
Set ftnoteclmn2 = Selection.Range

'מצא את סוף העמוד
currPageRange.Footnotes(lastftnote).Range.Select
Selection.EndKey Unit:=wdLine

pg2num = Selection.Information(wdActiveEndPageNumber)
Do While pg2num <> currpagenum
    Selection.MoveLeft Unit:=wdWord, Count:=1
    pg2num = Selection.Range.Information(wdActiveEndPageNumber)
Loop
'Selection.MoveRight Unit:=wdWord, Count:=1

'הגדר את סוף הטור השני
ftnoteclmn2.End = Selection.Range.Start

End Sub

[pcinfogmach]

מאקרו חמוד להעתקת כל המודולים הרגילים וכל חלקי היוזרפורם מתוך תבנית אחת לשניה

Sub CopyModulesToTemplate()
    Dim sourceTemplate As Document
    Dim destinationTemplate As Document
    Dim sourceVBProject As Object
    Dim destinationVBProject As Object
    Dim sourceComponent As Object
    Dim destinationComponent As Object

    ' Set the source and destination templates
    Set sourceTemplate = Documents.Open("C:\tosaf\t.dotm")
    Set destinationTemplate = Documents.Open("C:\tosaf\n.dotm")
    
    ' Get the VB projects from the templates
    Set sourceVBProject = sourceTemplate.VBProject
    Set destinationVBProject = destinationTemplate.VBProject

    ' Copy each module and user form from the source template to the destination template
    For Each sourceComponent In sourceVBProject.VBComponents
        ' Skip any components that are not modules or user forms
        If sourceComponent.Type = 1 Or sourceComponent.Type = 3 Then ' 1 = vbext_ct_StdModule, 3 = vbext_ct_MSForm
            ' Copy the component
            sourceComponent.Export sourceComponent.Name & ".bas"
            Set destinationComponent = destinationVBProject.VBComponents.Import(sourceComponent.Name & ".bas")
            ' Clean up the exported file
            Kill sourceComponent.Name & ".bas"
            ' Optionally rename the component in the destination template
            On Error Resume Next
            destinationComponent.Name = sourceComponent.Name
        End If
    Next sourceComponent

    ' Save and close the templates
    sourceTemplate.Close SaveChanges:=False
    destinationTemplate.Save
    destinationTemplate.Close SaveChanges:=True
End Sub

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

Sub CopyModulesToTemplate()
    Dim sourceTemplate As Document
    Dim destinationTemplate As Document
    Dim sourceVBProject As Object
    Dim destinationVBProject As Object
    Dim sourceComponent As Object
    Dim destinationComponent As Object
    Dim existingComponent As Object

    ' Set the source and destination templates
    Set sourceTemplate = Documents.Open("C:\tosaf\t.dotm")
    Set destinationTemplate = Documents.Open("C:\tosaf\n.dotm")
    
    ' Get the VB projects from the templates
    Set sourceVBProject = sourceTemplate.VBProject
    Set destinationVBProject = destinationTemplate.VBProject

' Copy each module and user form from the source template to the destination template
    For Each sourceComponent In sourceVBProject.VBComponents
        ' Skip any components that are not modules or user forms
        If sourceComponent.Type = 1 Or sourceComponent.Type = 3 Then ' 1 = vbext_ct_StdModule, 3 = vbext_ct_MSForm
            ' Check if a component with the same name already exists in the destination template
            Set existingComponent = destinationVBProject.VBComponents.Item(sourceComponent.Name)
            If Not existingComponent Is Nothing Then
                ' If a component with the same name exists, remove it before importing the new component
                destinationVBProject.VBComponents.remove existingComponent
            End If
            ' Copy the component
            sourceComponent.Export sourceComponent.Name & ".bas"
            Set destinationComponent = destinationVBProject.VBComponents.Import(sourceComponent.Name & ".bas")
            ' Clean up the exported file
            Kill sourceComponent.Name & ".bas"
            ' Optionally rename the component in the destination template
            destinationComponent.Name = sourceComponent.Name
        End If
    Next sourceComponent

    ' Save and close the templates
    sourceTemplate.Close SaveChanges:=False
    destinationTemplate.Save
    destinationTemplate.Close SaveChanges:=True
End Sub

[pcinfogmach]

קוד לשינוי שפת המקלדת לעברית

Option Private Module

Private Declare Function GetKeyboardLayoutName Lib "user32" Alias "GetKeyboardLayoutNameA" (ByVal pwszKLID As String) As Long
Private Declare Function ActivateKeyboardLayout Lib "user32" (ByVal hkl As Long, ByVal flags As Long) As Long

Private Const LANG_HEBREW As Long = &H40D

Public Sub SetHebrewInputLanguage()
    Dim keyboardLayout As String * 8 ' Maximum size for the keyboard layout name
    Dim result As Long
    
    ' Call the GetKeyboardLayoutName function
    result = GetKeyboardLayoutName(keyboardLayout)
    
    ' Check if the function call was successful (non-zero result)
    If result <> 0 Then
    
        ' The keyboardLayout string now contains the language identifier
        Dim languageID As String
        languageID = Left(keyboardLayout, 8)
        
        ' Check if the language identifier is for Hebrew (0000040D)
        If StrComp(languageID, "0000040D", vbTextCompare) = 0 Then
            Debug.Print "Current input language is already Hebrew."
        Else
            
            ' Change the input language to Hebrew
            Dim hkl As Long
            hkl = LANG_HEBREW
            result = ActivateKeyboardLayout(hkl, 0)
            
            If result <> 0 Then
                Debug.Print "Input language changed to Hebrew."
            Else
                Debug.Print "Failed to change the input language to Hebrew."
            End If
        End If
    Else
        Debug.Print "Failed to retrieve the input language."
    End If
End Sub

[pcinfogmach]

קוד לייצוא שמות הקבצים מתוך תיקייה מסויימת (הקוד מייצא גם את נתיב הקובץ וגם את שם הקובץ)
שימו לב! כרגע היצוא הוא בשיטת debug יש להחליף לשיטת הייצוא הרצויה.

Sub FindFilesInDirectoryAndSubfoldersLateBound()
    Dim fso As Object ' Declare fso as Object data type
    Dim folderPath As String
    Dim myFolder As Object ' Declare myFolder as Object data type
    Dim subfolder As Object ' Declare subfolder as Object data type
    Dim file As Object ' Declare file as Object data type

    ' Set the folder path where you want to search for files
    folderPath = "C:\Users\0533105132\Documents\ToratEmetInstall\Books" ' Replace with the desired folder path

    ' Create a new late-bound FileSystemObject
    Set fso = CreateObject("Scripting.FileSystemObject")

    ' Check if the specified folder exists
    If fso.FolderExists(folderPath) Then
        ' Get the Folder object for the specified folder
        Set myFolder = fso.getfolder(folderPath)

        ' Call the recursive function to search files in the main folder and its subfolders
        ProcessFolder myFolder
    Else
        ' Folder does not exist
        MsgBox "Folder not found: " & folderPath
    End If

    ' Release the objects
    Set file = Nothing
    Set subfolder = Nothing
    Set myFolder = Nothing
    Set fso = Nothing
End Sub

Sub ProcessFolder(ByVal folder As Object)
    Dim myfile As Object
    Dim subfolder As Object

    ' Process files in the current folder
    For Each myfile In folder.Files
        ' Print the file name (you can perform any desired action here)
        Debug.Print myfile.Path
        Debug.Print myfile.Name
        
    Next myfile

    ' Recursively process subfolders
    For Each subfolder In folder.Subfolders
        ProcessFolder subfolder
    Next subfolder
End Sub