Applied Knowledge: VBA

Showing posts with label VBA. Show all posts

Saturday, May 10, 2025

VBA Replace lines which contains date in specific format with specific text

VBA code to replace all rows from a text file which contains date format like Jan 09, 2025 with text ANSWER. The code should also check if line begins with single tab before the date.

Sub ReplaceLinesWithSpecificDateFormat()
    Dim fso As Object
    Dim inputFile As Object
    Dim outputFile As Object
    Dim filePath As String
    Dim tempPath As String
    Dim line As String
    Dim regex As Object

    ' Change this to your actual file path
    filePath = "C:\Path\To\Your\File.txt"
    tempPath = filePath & ".tmp"

    Set fso = CreateObject("Scripting.FileSystemObject")
    Set inputFile = fso.OpenTextFile(filePath, 1) ' ForReading
    Set outputFile = fso.CreateTextFile(tempPath, True) ' Overwrite

    ' Create RegExp to match lines starting with tab and a date like May 09, 2025
    Set regex = CreateObject("VBScript.RegExp")
    With regex
        .Pattern = "^\t(January|February|March|April|May|June|July|August|September|October|November|December) \d{2}, \d{4}"
        .IgnoreCase = True
        .Global = False
    End With

    ' Read each line and write to temp file, replacing matching lines with "ANSWER"
    Do Until inputFile.AtEndOfStream
        line = inputFile.ReadLine
        If regex.Test(line) Then
            outputFile.WriteLine "ANSWER"
        Else
            outputFile.WriteLine line
        End If
    Loop

    inputFile.Close
    outputFile.Close

    ' Replace original file with modified content
    fso.DeleteFile filePath
    fso.MoveFile tempPath, filePath

    MsgBox "Matching lines replaced with 'ANSWER'!", vbInformation
End Sub

VBA Delete lines which contains date in specific format

VBA code to delete all rows from a text file which contains date format like Jan 09, 2025. The code should also check if line begins with single tab before the date.

Sub DeleteLinesWithSpecificDateFormat()
    Dim fso As Object
    Dim inputFile As Object
    Dim outputFile As Object
    Dim filePath As String
    Dim tempPath As String
    Dim line As String
    Dim regex As Object

    ' Change this to your actual file path
    filePath = "C:\Users\ajeet\Desktop\meta\meta.txt"
    tempPath = filePath & ".tmp"

    Set fso = CreateObject("Scripting.FileSystemObject")
    Set inputFile = fso.OpenTextFile(filePath, 1) ' ForReading
    Set outputFile = fso.CreateTextFile(tempPath, True) ' Overwrite

    ' Create RegExp to match lines starting with tab and a date like May 09, 2025
    Set regex = CreateObject("VBScript.RegExp")
    With regex
        .Pattern = "^\t(Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec) \d{2}, \d{4}"
        .IgnoreCase = True
        .Global = False
    End With

    ' Read each line and write to temp file if it doesn't match
    Do Until inputFile.AtEndOfStream
        line = inputFile.ReadLine
        If Not regex.Test(line) Then
            outputFile.WriteLine line
        End If
    Loop

    inputFile.Close
    outputFile.Close

    ' Replace original file with filtered content
    fso.DeleteFile filePath
    fso.MoveFile tempPath, filePath

    MsgBox "Lines removed successfully!", vbInformation
End Sub

Wednesday, April 30, 2025

VBA Word - Convert Pipe Tables To Word Tables Latest


Sub ConvertPipeTablesToWordTables()
    Dim doc As Document
    Set doc = ActiveDocument

    Dim rngFind As Range
    Set rngFind = doc.Content.Duplicate

    Dim tableDict As Scripting.Dictionary
    Set tableDict = New Scripting.Dictionary

    Dim rowCounter As Long
    rowCounter = 1

    With rngFind.Find
        .Text = "|--"
        .Forward = True
        .Wrap = wdFindStop
        .MatchWildcards = False
    End With

    Do While rngFind.Find.Execute
        Dim anchorPara As Paragraph
        Set anchorPara = rngFind.Paragraphs(1)

        Dim headerPara As Paragraph
        Set headerPara = anchorPara.Previous

        If Not headerPara Is Nothing Then
            If IsValidTableRow(headerPara.Range.Text) Then
                ' Clear existing dictionary for reuse
                tableDict.RemoveAll
                rowCounter = 1

                ' Store header row
                tableDict.Add rowCounter, headerPara.Range.Text
                rowCounter = rowCounter + 1

                ' Prepare range for deleting data lines (excluding anchorPara)
                Dim dataRange As Range
                Set dataRange = Nothing

                ' Collect data rows
                Dim nextPara As Paragraph
                Set nextPara = anchorPara.Next

                Do While Not nextPara Is Nothing
                    If IsValidTableRow(nextPara.Range.Text) Then
                        tableDict.Add rowCounter, nextPara.Range.Text
                        rowCounter = rowCounter + 1

                        If dataRange Is Nothing Then
                            Set dataRange = nextPara.Range.Duplicate
                        Else
                            dataRange.End = nextPara.Range.End
                        End If

                        Set nextPara = nextPara.Next
                    Else
                        Exit Do
                    End If
                Loop

                ' Insert table at header position
                InsertTableFromDictionary tableDict, headerPara.Range

                ' Delete only the data lines (not the anchor)
                If Not dataRange Is Nothing Then dataRange.Delete

                ' Now delete the anchor row separately
                anchorPara.Range.Delete
            End If
        End If

        rngFind.Start = anchorPara.Range.End + 1
        rngFind.End = doc.Content.End
    Loop

    Set tableDict = Nothing
End Sub

Function IsValidTableRow(lineText As String) As Boolean
    Dim trimmed As String
    trimmed = Trim(lineText)

    Dim pipeCount As Long
    pipeCount = UBound(Split(trimmed, "|")) - 1

    IsValidTableRow = (pipeCount >= 2 And InStr(trimmed, "|") > 0)
End Function

Sub InsertTableFromDictionary(dict As Scripting.Dictionary, insertRange As Range)
    If dict.Count = 0 Then Exit Sub

    Dim rowCount As Long: rowCount = dict.Count
    Dim colCount As Long: colCount = UBound(Split(dict.Item(1), "|")) - 1

    Dim tbl As Table
    Set tbl = insertRange.Tables.Add(Range:=insertRange, NumRows:=rowCount, NumColumns:=colCount)
    tbl.Borders.Enable = True

    Dim r As Long, c As Long, i As Long
    For r = 1 To rowCount
        Dim cells() As String
        cells = Split(dict.Item(r), "|")

        c = 1
        For i = 1 To UBound(cells) - 1
            tbl.Cell(r, c).Range.Text = Trim(cells(i))
            c = c + 1
        Next i
    Next r

    ' Bold the first row (header)
    tbl.Rows(1).Range.Bold = True
End Sub

Tuesday, April 29, 2025

Word VBA - Convert ChatGPT file into Word document

Run subroutines one by one in order:

Sub ChatGptDocumentMaker()
    ClearBgColorGrotic1One
    BoldTextBetweenUserAndChatGPT2Two
    ReplaceUser3Three
    ReplaceGPTbyAnswer4Four
    DoubleParaToSingle5Five
    BoldTextBeforeLastDoubleStars6Six
    BoldAndColorLinesStartingWithTripleHash7Seven
    AdjustTableWidths8Eight
    AdjustImageSizes9Nine
    FormatTripleBacktickSections10Ten
    DeleteLineContainingTripleBackticks11Eleven
End Sub

Run the following code to select document and remove special formatting

Sub ClearBgColorGrotic1One()
    Selection.WholeStory
    Selection.Font.Name = "a_Grotic"
    Selection.Shading.Texture = wdTextureNone
    Selection.Shading.ForegroundPatternColor = wdColorAutomatic
    Selection.Shading.BackgroundPatternColor = wdColorAutomatic
End Sub

Run the following code to Bold Text between user and ChatGPT

Sub BoldTextBetweenUserAndChatGPT2Two()
    Selection.HomeKey Unit:=wdStory
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    Selection.Find.Replacement.Font.Bold = True

    With Selection.Find
        .Text = "user^13(*)ChatGPT^13"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchWildcards = True
    End With
    
    With Selection.Find.Replacement.Font
        .Size = 10
        .Bold = True
        .Color = wdColorBlue
        .Name = "Georgia"
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
End Sub

Run the following code

Sub ReplaceUser3Three()
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    
    With Selection.Find
        .Text = "user^13"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
End Sub

Run the following code:

Sub ReplaceGPTbyAnswer4Four()
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find.Replacement.Font
        .Size = 10
        .Bold = False
        .Italic = False
        .Color = wdColorBlack
        .Name = "Courier New"
    End With
    With Selection.Find
        .Text = "ChatGPT^p"
        .Replacement.Text = "Answer: "
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
End Sub

Run the following code:

Sub DoubleParaToSingle5Five()
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "^p^p"
        .Replacement.Text = "^p"
        .Forward = True
        .Wrap = wdFindContinue
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
End Sub

Run the following code:

Sub BoldTextBeforeLastDoubleStars6Six()
    Dim doc As Document
    Dim para As Paragraph
    Dim pos As Integer
    Dim lineText As String
    Dim rng As Range
    Dim lastPos As Integer
    
    ' Set the document
    Set doc = ActiveDocument
    
    ' Loop through each paragraph in the document
    For Each para In doc.Paragraphs
        lineText = para.Range.Text
        lastPos = InStrRev(lineText, "**")
        
        ' If '**' is found, bold the preceding text
        If lastPos > 1 Then
            Set rng = para.Range.Duplicate
            rng.End = rng.Start + lastPos - 1
            rng.Font.Bold = True
        End If
    Next para
End Sub

Run the following code:

Sub BoldAndColorLinesStartingWithTripleHash7Seven()
    Dim doc As Document
    Dim para As Paragraph
    Dim lineText As String
    Dim rng As Range
    Dim pos As Integer
    
    ' Set the document
    Set doc = ActiveDocument
    
    ' Loop through each paragraph in the document
    For Each para In doc.Paragraphs
        lineText = para.Range.Text
        pos = InStr(lineText, "###")
        
        ' If the paragraph starts with '###', format the entire paragraph
        If pos = 1 Then
            Set rng = para.Range
            rng.Font.Bold = True
            rng.Font.Color = wdColorBrown
            rng.Font.Size = 10
        End If
    Next para
End Sub

Run the following code:

Sub AdjustTableWidths8Eight()
    Dim doc As Document
    Dim tbl As Table
    Dim tblWidth As Single
    Dim docWidth As Single

    Set doc = ActiveDocument
    docWidth = doc.PageSetup.PageWidth - doc.PageSetup.LeftMargin - doc.PageSetup.RightMargin

    For Each tbl In doc.Tables
        tblWidth = tbl.PreferredWidth

        If tblWidth > docWidth Then
            tbl.PreferredWidth = docWidth
            tbl.AllowAutoFit = False ' Prevent autofit to ensure width stays as set
            ' Optionally, you can adjust column widths proportionally
            Dim col As Column
            Dim totalColWidth As Single
            totalColWidth = 0

            ' Calculate total width of columns
            For Each col In tbl.Columns
                totalColWidth = totalColWidth + col.Width
            Next col

            ' Adjust each column proportionally
            For Each col In tbl.Columns
                col.Width = col.Width * docWidth / totalColWidth
            Next col
        End If
    Next tbl
End Sub

Run the following code

Sub AdjustImageSizes9Nine()
    Dim doc As Document
    Dim img As InlineShape
    Dim shape As shape
    Dim docWidth As Single

    Set doc = ActiveDocument
    docWidth = doc.PageSetup.PageWidth - doc.PageSetup.LeftMargin - doc.PageSetup.RightMargin

    ' Loop through all inline shapes (embedded images)
    For Each img In doc.InlineShapes
        If img.Width > docWidth Then
            img.LockAspectRatio = msoTrue
            img.Width = docWidth
        End If
    Next img

    ' Loop through all floating shapes (floating images)
    For Each shape In doc.Shapes
        If shape.Type = msoPicture Or shape.Type = msoLinkedPicture Then
            If shape.Width > docWidth Then
                shape.LockAspectRatio = msoTrue
                shape.Width = docWidth
            End If
        End If
    Next shape
End Sub

Run the following code:

Sub FormatTripleBacktickSections10Ten()
    Dim doc As Document
    Dim rng As Range
    Dim startRng As Range
    Dim endRng As Range
    Dim textRng As Range
    Dim found As Boolean
    Dim languages As Variant
    Dim i As Integer

    Set doc = ActiveDocument
    Set rng = doc.Content

    ' Array of languages to check
    languages = Array("```csharp", "```css", "```html", "```javascript", "```sql")

    For i = LBound(languages) To UBound(languages)
        With rng.Find
            .ClearFormatting
            .Text = languages(i) & "^13"

            Do While .Execute(Forward:=True) = True
                ' Set the start range at the end of the found triple backticks line
                Set startRng = rng.Duplicate
                startRng.Collapse Direction:=wdCollapseEnd

                ' Find the closing triple backticks
                With startRng.Find
                    .Text = "```^13"
                    If .Execute(Forward:=True) = True Then
                        ' Set the end range at the start of the found triple backticks line
                        Set endRng = startRng.Duplicate
                        endRng.Collapse Direction:=wdCollapseStart

                        ' Set the text range between the end of the starting triple backticks and the start of the ending triple backticks
                        Set textRng = doc.Range(rng.End, startRng.Start - 1)

                        ' Apply single line spacing, before spacing 5pt, and after spacing 5pt
                        With textRng.ParagraphFormat
                            .SpaceBefore = 5
                            .SpaceAfter = 5
                            .LineSpacingRule = wdLineSpaceSingle
                        End With

                        ' Apply font style and color
                        With textRng.Font
                            .Name = "Calibri" ' or "Arial Narrow"
                            .Size = 9 ' Adjust the font size as needed
                        End With

                        ' Fill the background color with a very light cyan
                        textRng.Shading.BackgroundPatternColor = RGB(204, 255, 255) ' Light cyan

                    End If
                End With

                ' Move the main search range past the found end triple backticks
                rng.Start = startRng.End
            Loop
        End With

        ' Reset the range for the next language search
        Set rng = doc.Content
    Next i
End Sub

Run the following code

Sub DeleteLineContainingTripleBackticks11Eleven()
    Dim doc As Document
    Dim rng As Range
    Dim findText As String
    
    ' The text to search for: any word starting with ```
    findText = "```"
    
    Set doc = ActiveDocument
    Set rng = doc.Content
    
    With rng.Find
        .ClearFormatting
        .Text = findText
        .Forward = True
        .Wrap = wdFindStop
        
        Do While .Execute
            ' Move range to the start of the line containing the found text
            rng.Start = rng.Paragraphs(1).Range.Start
            ' Extend range to the end of the line
            rng.End = rng.Paragraphs(1).Range.End
            ' Delete the line
            rng.Delete
            
            ' Move to the next instance
            rng.Collapse Direction:=wdCollapseEnd
        Loop
    End With
End Sub

Run the following code

Sub ExtractQuestionsAndMoveToTopPerfectUsingDictionary()
    Dim doc As Document
    Dim para As Paragraph
    Dim questionsDict As Object
    Dim questionRangesDict As Object
    Dim k As Integer
    Dim questionText As String
    Dim rngQStart As Range
    Dim topRng As Range
    Dim key As Variant

    ' Initialize the document and dictionaries
    Set doc = ActiveDocument
    Set questionsDict = CreateObject("Scripting.Dictionary")
    Set questionRangesDict = CreateObject("Scripting.Dictionary")
    k = 1
    questionText = ""

    ' Loop through each paragraph in the document
    For Each para In doc.Paragraphs
        ' Check if the paragraph has the required format
        With para.Range.Font
            If .Name = "Georgia" And .Size = 10 And .Bold = True And .Color = RGB(0, 0, 255) Then
                ' Store the starting range of the question
                If questionText = "" Then
                    Set rngQStart = para.Range.Duplicate
                End If
                ' Append the plain text of the paragraph to the question text
                questionText = questionText & para.Range.Text
            ElseIf Len(questionText) &gt; 0 Then
                ' Store the collected question text in the dictionary
                questionsDict.Add k, questionText
                questionRangesDict.Add k, rngQStart
                k = k + 1
                questionText = ""
            End If
        End With
    Next para

    ' If there's any remaining question text, add it to the dictionaries
    If Len(questionText) &gt; 0 Then
        questionsDict.Add k, questionText
        questionRangesDict.Add k, rngQStart
    End If

    ' Set the range to the start of the document to insert questions
    Set topRng = doc.Range(0, 0)

    ' Insert questions and hyperlinks at the top of the document in reverse order
    For i = questionsDict.Count To 1 Step -1
        ' Insert question with key
        topRng.InsertAfter questionsDict(i) & vbCrLf
        
        ' Move the range to the end of the newly added text
        Set topRng = doc.Range(0, 0)
        topRng.Collapse wdCollapseEnd
        
        ' Add a bookmark and hyperlink
        AddHyperlink topRng, "Q" & i, questionRangesDict(i)
    Next i
End Sub

Run the following code

Sub AddHyperlink(rng As Range, displayText As String, targetRange As Range)
    ' Add a bookmark at the target range so that the hyperlink can reference it
    On Error Resume Next
    ActiveDocument.Bookmarks.Add Name:=displayText, Range:=targetRange
    On Error GoTo 0

    ' Add a hyperlink to the specified range
    ActiveDocument.Hyperlinks.Add _
        Anchor:=rng, _
        Address:="", _
        SubAddress:=displayText, _
        TextToDisplay:=displayText
End Sub

Monday, April 28, 2025

VBA Sequence ChatGPT Code

This VBA code is used to Sequence my personal ChatGPT Word document.

''' Date 2024 July30

 Sub ChatGPT_Sequence()
    ClearAllColorBg1
    BoldTextBetweenUserAndChatGPT2
    ReplaceUser3
    ReplaceGPTbyAnswer4
    DoubleParaToSingle5
    BoldTextBeforeLastDoubleStars
    BoldAndColorLinesStartingWithTripleHash
    MsgBox "Done"
End Sub

 Sub ClearAllColorBg1()
    Selection.WholeStory
    Selection.Shading.Texture = wdTextureNone
    Selection.Shading.ForegroundPatternColor = wdColorAutomatic
    Selection.Shading.BackgroundPatternColor = wdColorAutomatic
End Sub

 Sub BoldTextBetweenUserAndChatGPT2()
    Selection.HomeKey Unit:=wdStory
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    Selection.Find.Replacement.Font.Bold = True

    With Selection.Find
        .Text = "user^13(*)ChatGPT^13"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchWildcards = True
    End With
    
    With Selection.Find.Replacement.Font
        .Size = 10
        .Bold = True
        .Color = wdColorBlue
        .Name = "Georgia"
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
End Sub

 Sub ReplaceUser3()
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    
    With Selection.Find
        .Text = "user"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
End Sub

 Sub ReplaceGPTbyAnswer4()
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find.Replacement.Font
        .Size = 10
        .Bold = False
        .Italic = False
        .Color = wdColorBlack
        .Name = "Courier New"
    End With
    With Selection.Find
        .Text = "ChatGPT^p"
        .Replacement.Text = "Answer: "
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
End Sub

 Sub DoubleParaToSingle5()
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "^p^p"
        .Replacement.Text = "^p"
        .Forward = True
        .Wrap = wdFindContinue
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
End Sub

 Sub BoldBeforeStarsColon6()
    
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    Selection.Find.Replacement.Font.Bold = True
    With Selection.Find
        .Text = "^13[!^13]@\*\*:"
        .Replacement.Text = ""
        .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 BoldBeforeColonStars6B()
    
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    Selection.Find.Replacement.Font.Bold = True
    With Selection.Find
        .Text = "^13[!^13]@:\*\*"
        .Replacement.Text = ""
        .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 BoldBetweenStars7()
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    Selection.Find.Replacement.Font.Bold = True
    With Selection.Find
        .Text = "\*\*[!^13]@\*\*"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchWildcards = True
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
End Sub

 Sub TripleHash8()

    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find.Replacement.Font
        .Size = 10
        .Bold = False
        .Italic = False
        .Color = wdColorBrown
        .Name = "Courier New"
    End With
    
    With Selection.Find
        .Text = "^13###*^13"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
End Sub

 Sub BoldTextBeforeLastDoubleStars()
    Dim doc As Document
    Dim para As Paragraph
    Dim pos As Integer
    Dim lineText As String
    Dim rng As Range
    Dim lastPos As Integer
    
    ' Set the document
    Set doc = ActiveDocument
    
    ' Loop through each paragraph in the document
    For Each para In doc.Paragraphs
        lineText = para.Range.Text
        lastPos = InStrRev(lineText, "**")
        
        ' If '**' is found, bold the preceding text
        If lastPos > 1 Then
            Set rng = para.Range.Duplicate
            rng.End = rng.Start + lastPos - 1
            rng.Font.Bold = True
        End If
    Next para
End Sub

 Sub BoldAndColorLinesStartingWithTripleHash()
    Dim doc As Document
    Dim para As Paragraph
    Dim lineText As String
    Dim rng As Range
    Dim pos As Integer
    
    ' Set the document
    Set doc = ActiveDocument
    
    ' Loop through each paragraph in the document
    For Each para In doc.Paragraphs
        lineText = para.Range.Text
        pos = InStr(lineText, "###")
        
        ' If the paragraph starts with '###', format the entire paragraph
        If pos = 1 Then
            Set rng = para.Range
            rng.Font.Bold = True
            rng.Font.Color = wdColorBrown
            rng.Font.Size = 11
        End If
    Next para
End Sub

Thursday, January 16, 2025

VBA Word - Process all Word documents of a folder, Delete specific lines

The following VBA code processes all Word documents of a folder one by one. It deletes specific lines which contain some specific texts.

Option Explicit

Sub ProcessFiles()
    Dim FSO As Object
    Dim objFldr As Object
    Dim objFyle As Object
    Dim strFileExtension As String
    Dim appWord As Object
    Dim doc As Object
    
    ' Initialize FileSystemObject
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set objFldr = GetFolder()
    
    If objFldr Is Nothing Then Exit Sub ' Exit if no folder is selected

    ' Initialize Word Application
    Set appWord = CreateObject("Word.Application")
    appWord.Visible = True
    
    ' Process each file in the selected folder
    For Each objFyle In objFldr.Files
        strFileExtension = FSO.GetExtensionName(objFyle.Path)
        If LCase(strFileExtension) = "docx" Or LCase(strFileExtension) = "doc" Then
            ' Open the Word document
            Set doc = appWord.Documents.Open(objFyle.Path)
            doc.Activate
            
            ' Apply table style
            Call TableGridDesignMacro
            
            ' Delete specified lines
            Call DeleteLineBeforeAndContainingCopyCode(doc, "You said:")
            Call DeleteLineBeforeAndContainingCopyCode(doc, "Copy code")
            Call DeleteLineBeforeAndContainingCopyCode(doc, "ChatGPT")
            
            ' Save and close the document
            doc.Save
            doc.Close SaveChanges:=True
            Set doc = Nothing
        End If
    Next
    
    ' Quit Word Application
    appWord.Quit
    Set appWord = Nothing
    Set FSO = Nothing
End Sub

Sub DeleteLineBeforeAndContainingCopyCode(doc As Object, strText As String)
    Dim findRange As Range
    Dim deleteRange As Range

    ' Start from the end of the document
    Set findRange = doc.Content
    findRange.Start = findRange.End
    
    ' Search for the text and delete lines
    Do While findRange.Find.Execute(FindText:=strText, Forward:=False, Wrap:=wdFindStop)
        ' Create a range for the current line
        Set deleteRange = findRange.Paragraphs(1).Range
        
        ' Include the line above if it exists
        If deleteRange.Start > doc.Content.Start Then
            deleteRange.Start = deleteRange.Paragraphs(1).Previous.Range.Start
        End If
        
        ' Delete the range
        deleteRange.Delete
    Loop
End Sub

Function GetFolder() As Object
    Dim FSO As Object
    Dim strFolderPath As String
    Dim objFldr As Object

    ' Create a FileSystemObject
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    ' Use FileDialog to let the user select a folder
    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        .Show
        If .SelectedItems.Count <> 1 Then Exit Function ' Exit if no folder is selected
        strFolderPath = .SelectedItems.Item(1)
    End With
    
    ' Get the selected folder
    Set objFldr = FSO.GetFolder(strFolderPath)
    
    ' Check if the folder contains files
    If objFldr.Files.Count < 1 Then
        MsgBox "No files found in the selected folder.", vbInformation
        Exit Function
    End If
    
    ' Return the folder object
    Set GetFolder = objFldr
    Set FSO = Nothing
End Function

Sub TableGridDesignMacro()
    Dim tbl As Table
    ' Apply "Table Grid" style to all tables in the document
    For Each tbl In ActiveDocument.Tables
        tbl.Style = "Table Grid"
    Next
End Sub

Tuesday, December 24, 2024

VBA Word - Extract questions from document and consolidate them at one place

The following code extracts questions from word document based on the format of questions. Each question has specific font style, color, size etc. Based on this information, each question is stored in Dictionary object: question number is key and question is value. Look at the code below which extracts questions from document and place them at top of the document to consolidate them at one place:

Sub ExtractQuestionsAndMoveToTopPerfectUsingDictionary()
    Dim doc As Document
    Dim para As Paragraph
    Dim questionsDict As Object
    Dim questionRangesDict As Object
    Dim k As Integer
    Dim questionText As String
    Dim rngQStart As Range
    Dim topRng As Range
    Dim key As Variant
    Dim result As Variant
    
    result = MsgBox("Continue?", vbOKCancel, "Chat GPT Document Maker")
    If result = vbOK Then
        ' Initialize the document and dictionaries
        Set doc = ActiveDocument
        Set questionsDict = CreateObject("Scripting.Dictionary")
        Set questionRangesDict = CreateObject("Scripting.Dictionary")
        k = 1
        questionText = ""
    
        ' Loop through each paragraph in the document
        For Each para In doc.Paragraphs
            ' Check if the paragraph has the required format
            With para.Range.Font
                If .Name = "Georgia" And .Size = 10 And .Bold = True And .Color = RGB(0, 0, 255) Then
                    ' Store the starting range of the question
                    If questionText = "" Then
                        Set rngQStart = para.Range.Duplicate
                    End If
                    ' Append the plain text of the paragraph to the question text
                    questionText = questionText & para.Range.Text
                ElseIf Len(questionText) > 0 Then
                    ' Store the collected question text in the dictionary
                    questionsDict.Add k, questionText
                    questionRangesDict.Add k, rngQStart
                    k = k + 1
                    questionText = ""
                End If
            End With
        Next para
    
        ' If there's any remaining question text, add it to the dictionaries
        If Len(questionText) > 0 Then
            questionsDict.Add k, questionText
            questionRangesDict.Add k, rngQStart
        End If
    
        ' Set the range to the start of the document to insert questions
        Set topRng = doc.Range(0, 0)
    
        ' Insert questions and hyperlinks at the top of the document in reverse order
        For i = questionsDict.Count To 1 Step -1
            ' Insert question with key
            topRng.InsertAfter questionsDict(i)
            
            ' Move the range to the end of the newly added text
            Set topRng = doc.Range(0, 0)
            topRng.Collapse wdCollapseEnd
            
            ' Add a bookmark and hyperlink
            AddHyperlink topRng, "Question" & i, questionRangesDict(i)
            topRng.InsertAfter vbCrLf
        Next i
    End If
End Sub

Now, the consolidated questions are provided hyperlinks to reach to their answers.

Sub AddHyperlink(rng As Range, displayText As String, targetRange As Range)
    ' Add a bookmark at the target range so that the hyperlink can reference it
    On Error Resume Next
    ActiveDocument.Bookmarks.Add Name:=displayText, Range:=targetRange
    On Error GoTo 0

    ' Add a hyperlink to the specified range
    ActiveDocument.Hyperlinks.Add _
        Anchor:=rng, _
        Address:="", _
        SubAddress:=displayText, _
        TextToDisplay:=displayText
End Sub

VBA Excel - delete blank rows from Excel sheet:

The following code deletes blank rows from Excel sheet:

Sub pDelBlnkRws()
    Dim lngMaxR As Long
    Dim lngC As Long
    Dim rngStart As Range
    
    On Error GoTo lblError3
    
    Set rngStart = Sheet1.Range("A" & Sheet1.Rows.CountLarge)
    
    For lngC = 1 To 11
        If rngStart.End(xlUp).Row > lngMaxR Then
            lngMaxR = rngStart.End(xlUp).Row
        End If
        Set rngStart = rngStart.Offset(ColumnOffset:=1)
    Next
       
    For lngC = lngMaxR To 1 Step -1
        With Sheet1
            If Application.WorksheetFunction.CountA(.Range("A" & lngC).EntireRow) = 0 Then
                .Range("A" & lngC).EntireRow.Delete
            End If
        End With
    Next
    
lblError3:
If Err.Number <> 0 Then
    MsgBox "Error Number:" & Err.Number & vbCrLf & "Error Description: " & Err.Number
End If
End Sub

VBA Word - how to generate HTML file

The following VBA code explains how to generate HTML file:

Option Explicit
 
'declare all variables
Dim objWord
Dim oDoc
Dim objFso
Dim colFiles
Dim curFile
Dim curFileName
Dim folderToScanExists
Dim folderToSaveExists
Dim objFolderToScan
 
'set some of the variables
folderToScanExists = False
folderToSaveExists = False
Const wdSaveFormat = 10 'for Filtered HTML output
 
'**********************************
'change the following to fit your system
Const folderToScan = "C:\Word\documentation\"
Const folderToSave = "C:\Inetpub\wwwroot\word\"
'**********************************
 
'Use FSO to see if the folders to read from
'and write to both exist.
'If they do, then set both flags to TRUE,
'and proceed with the function
Set objFso = CreateObject("Scripting.FileSystemObject")
If objFso.FolderExists(folderToScan) Then
  folderToScanExists = True
Else
  MsgBox "Folder to scan from does not exist!", 48, "File System Error"
End If
If objFso.FolderExists(folderToSave) Then
  folderToSaveExists = True
Else
  MsgBox "Folder to copy to does not exist!", 48, "File System Error"
End If
 
If (folderToScanExists And folderToSaveExists) Then
  'get your folder to scan
  Set objFolderToScan = objFso.GetFolder(folderToScan)
  'put al the files under it in a collection
  Set colFiles = objFolderToScan.Files
  'create an instance of Word
  Set objWord = CreateObject("Word.Application")
  If objWord Is Nothing Then
    MsgBox "Couldn't start Word.", 48, "Application Start Error"
  Else
    'for each file
    For Each curFile in colFiles
      'only if the file is of type DOC
      If (objFso.GetExtensionName(curFile) = "doc") Then
        'get the filename without extension
        curFileName = curFile.Name
        curFileName = Mid(curFileName, 1, InStrRev(curFileName, ".") - 1)
        'open the file inside Word
        objWord.Documents.Open objFso.GetAbsolutePathName(curFile)
        'do all this in the background
        objWord.Visible = False
        'create a new document and save it as Filtered HTML
        Set oDoc = objWord.ActiveDocument
        oDoc.SaveAs folderToSave & curFileName & ".htm", wdSaveFormat
        oDoc.Close
        Set oDoc = Nothing
      End If
    Next
  End If
  'close Word
  objWord.Quit
  'set all objects and collections to nothing
  Set objWord = Nothing
  Set colFiles = Nothing
  Set objFolderToScan = Nothing
End If
 
Set objFso = Nothing

VBA Dir function

VBA Notes: DIR Function

Syntax

DIR([pathname] [, attributes])

Returns the name of a file or directory matching a pattern or attribute (String).

Parameters

pathname (Optional):
The full path of a file or directory (String).
attributes (Optional):
A vbFileAttribute constant specifying the file attributes (Integer):

0 = vbNormal (default)
1 = vbReadOnly
2 = vbHidden
4 = vbSystem
8 = vbVolume (Macintosh only)
16 = vbDirectory
64 = vbAlias (Macintosh only)

Remarks

The pathname can include a directory and drive.
If the pathname cannot be found, a zero-length string ("") is returned.
The attributes parameter can be a constant or a numerical expression.

If omitted, 0 is used, representing files matching the pathname with no attributes.

Wildcard characters:

* (matches zero or more characters)
? (matches any single character)

To iterate over all files in a folder, specify an empty string ("") for the pathname.
First call to DIR requires a pathname. Subsequent calls can omit it to retrieve additional matching file names.
When no more files exist, an empty string is returned.
File names are not returned in a particular order. To display them in order, consider storing them in an array and sorting them.
The vbAlias and vbVolume attributes are only available on Macintosh.
Recursive calls to the DIR function are not allowed.
If attributes > 256, it is assumed to be a MacID value.
Use DIR$ to return a String data type instead of a Variant/String.
The MKDIR function can create new directories.
For SharePoint paths, use forward slashes (/) instead of backslashes (\) between subfolders.
The equivalent .NET function is Microsoft.VisualBasic.FileSystem.Dir

Simple examples:

Example 1: Locate a specific file

Dir("C:\Windows\test.ini")

Example 2: Find files matching a pattern

Dir("C:\Windows\*.ini")

Example 3: Get subsequent file names

Dir()

Example 4: Using a SharePoint path

Dir("//sharepoint-site/folder/subfolder")

Detailed Example:

'''''''''''''''''''''''''''''''''''''''''''
'   Capture file names in an array        '
'''''''''''''''''''''''''''''''''''''''''''
Option Base 1
Sub Capturefiles()
    Dim sPath As String
    Dim sFile As String
    Dim asFiles() As String
    Dim doc As Document
    sPath = "d:\C"
    ChDrive "d"
    ChDir sPath
    sFile = Dir(sPath & Application.PathSeparator & "*.c?")
    Do While sFile <> ""
        i = i + 1
        ReDim Preserve asFiles(1 To i)
        asFiles(i) = sFile
        sFile = Dir
    Loop
    If i = 0 Then
        MsgBox "No file in the folder"
    End If
    '''''''''''''''''''''''''''''''''''''''''''''
    '  Now process the Captured files in array  '
    '''''''''''''''''''''''''''''''''''''''''''''
        Application.ScreenUpdating = False
    'Now copy the whole Active document and paste in this document
    For i = 1 To UBound(asFiles)
        Set doc = Documents.Open(FileName:=sPath & Application.PathSeparator & asFiles(i))
        doc.Activate
        Selection.TypeParagraph
        Selection.TypeText Text:="Program No." & i
        Selection.HomeKey Unit:=wdLine, Extend:=wdExtend
        Selection.Font.Bold = wdToggle
        Selection.EndKey Unit:=wdLine
        Selection.Font.Bold = True
        Selection.TypeParagraph
        doc.Saved = True
        Selection.HomeKey Unit:=wdStory
        Selection.EndKey Unit:=wdStory, Extend:=wdExtend
        Selection.Copy
        ThisDocument.Select
        Selection.EndKey Unit:=wdStory
        Selection.PasteAndFormat (wdPasteDefault)
        doc.Close
    Next i
        Application.ScreenUpdating = True
End Sub
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    '  Now close all open documents if you missed to use close '
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

    Sub CloseAllDocs()
    For Each od In Documents
        od.Activate
        ActiveDocument.Close
    Next od
    End Sub

VBA Limitations

VBA (Visual Basic for Applications) is tightly integrated with the host application in which it runs (e.g., Microsoft Word, Excel, or PowerPoint).

Dependency on the Host Application: VBA cannot function independently. It requires a host application to be open because the VBA environment is part of that application. For example, to run VBA code written for Excel, you must have Excel open.
No Stand-Alone Applications: You cannot create a stand-alone executable (.exe) application with VBA. However, you can mimic a stand-alone application by hiding the host application (e.g., Excel or Word) while displaying user forms created in VBA. This gives the appearance of a separate application, but the host application is still running in the background.
VBA Environment Installation: The VBA environment is installed along with the host application (e.g., when you install Microsoft Office). The environment is loaded from your computer's hard disk when you open the host application.
Closure of VBA Environment: Since VBA is tied to the host application, closing the host application will also terminate the VBA environment and any running VBA code.

In summary, VBA is not a general-purpose programming platform. It is designed to extend and automate tasks within its host applications, and its functionality ends when the host application is closed.

VBA Word - Delete images from document with specific URL

The following VBA code deletes images from document with specific URL:

Sub DeleteImagesWithSpecificURL()
    Dim iShape As InlineShape
    Dim shp As Shape
    Dim doc As Document
    Dim searchURL As String
    
    searchURL = "https://hoven.in/aspnet-core/asp-net-core-course-buy.html"
    
    Set doc = ActiveDocument
    
    ' Check InlineShapes (images in the text flow)
    For Each iShape In doc.InlineShapes
        If iShape.Type = wdInlineShapePicture Then
            If InStr(1, iShape.AlternativeText, searchURL, vbTextCompare) > 0 Then
                iShape.Delete
            End If
        End If
    Next iShape
    
    ' Check Shapes (floating images)
    For Each shp In doc.Shapes
        If shp.Type = msoPicture Then
            If InStr(1, shp.AlternativeText, searchURL, vbTextCompare) > 0 Then
                shp.Delete
            End If
        End If
    Next shp
End Sub

VBA Word - Text formatting if text begins with some text

The following VBA code formats the text which begins with hash:

Sub BoldAndColorLinesStartingWithTripleHash()
    Dim doc As Document
    Dim para As Paragraph
    Dim lineText As String
    Dim rng As Range
    Dim pos As Integer
    
    ' Set the document
    Set doc = ActiveDocument
    
    ' Loop through each paragraph in the document
    For Each para In doc.Paragraphs
        lineText = para.Range.Text
        pos = InStr(lineText, "###")
        
        ' If the paragraph starts with '###', format the entire paragraph
        If pos = 1 Then
            Set rng = para.Range
            rng.Font.Bold = True
            rng.Font.Color = wdColorBrown
            rng.Font.Size = 11
        End If
    Next para
End Sub

VBA Word - Format Text of word document based on the properties of text

The following VBA code finds text with properties such as color, size and name in Word document and change their color etc.

Sub HighlightAndColorText()
    Dim doc As Document
    Dim rng As Range
    
    Set doc = ActiveDocument
    Set rng = doc.Content
    
    With rng.Find
        .ClearFormatting
        .Font.Color = RGB(0, 0, 255) ' Blue font color
        .Font.Size = 10 ' Font size
        .Font.Name = "Century Gothic" ' Font style
        
        Do While .Execute(Forward:=True, Format:=True) = True
            ' Set the background color to yellow
            rng.Shading.BackgroundPatternColor = wdColorBlack
            
            ' Change the font color to white
            rng.Font.Color = RGB(255, 255, 255)
            
            ' Move the search range to the end of the current found text
            rng.Collapse Direction:=wdCollapseEnd
        Loop
    End With
End Sub

VBA Word - Create custom headings, apply them and create Table of contents using the styles

The following code creates custom headings, apply them and create Table of contents using the styles in Word document:

Sub CreateCustomHeadings()
    Dim CustomHd1 As Style
    Dim CustomHd2 As Style
    
    ' Create CustomHd1 style
    Set CustomHd1 = ActiveDocument.Styles.Add(Name:="CustomHd1", Type:=wdStyleTypeParagraph)
    With CustomHd1.Font
        .Name = "Arial"
        .Size = 13.5
        .Bold = True
    End With
    
    ' Create CustomHd2 style
    Set CustomHd2 = ActiveDocument.Styles.Add(Name:="CustomHd2", Type:=wdStyleTypeParagraph)
    With CustomHd2.Font
        .Name = "Arial"
        .Size = 10
        .Bold = True
    End With
End Sub
Sub ApplyCustomHeadings()
    Dim para As Paragraph
    
    ' Loop through all paragraphs in the document
    For Each para In ActiveDocument.Paragraphs
        With para.Range
            ' Apply CustomHd1 if the font matches
            If .Font.Name = "Arial" And .Font.Size = 13.5 And .Font.Bold = True Then
                .Style = ActiveDocument.Styles("CustomHd1")
            ' Apply CustomHd2 if the font matches
            ElseIf .Font.Name = "Arial" And .Font.Size = 10 And .Font.Bold = True Then
                .Style = ActiveDocument.Styles("CustomHd2")
            End If
        End With
    Next para
End Sub
Sub CreateTOCWithCustomHeadings()
    Dim tocRange As Range
    Dim toc As TableOfContents
    
    ' Insert a paragraph at the beginning of the document for the TOC
    Set tocRange = ActiveDocument.Range(0, 0)
    tocRange.InsertParagraphBefore
    tocRange.InsertBefore "Table of Contents"
    tocRange.InsertParagraphAfter
    tocRange.InsertParagraphAfter
    
    ' Add the TOC using the custom heading styles
    Set toc = ActiveDocument.TablesOfContents.Add( _
        Range:=tocRange.Paragraphs(2).Range, _
        UseHeadingStyles:=False, _
        IncludePageNumbers:=True, _
        RightAlignPageNumbers:=True, _
        UseHyperlinks:=True _
    )
    
    ' Add the custom styles to the TOC
    toc.AddText Style:="CustomHd1", Level:=1
    toc.AddText Style:="CustomHd2", Level:=2
    
    ' Update the TOC to include all headings
    toc.Update
End Sub

VBA Word - Delete all hyperlinks from document

The following VBA code deletes all hyperlinks from document:

Sub DeleteHyperlinks()
    Dim doc As Document
    Dim hyp As Hyperlink
    Dim i As Integer
    Dim max As Integer
    
    max = ActiveDocument.Hyperlinks.Count
    On Error Resume Next
    For i = 1 To max
        ActiveDocument.Hyperlinks(i).Delete
    Next
End Sub

The following VBA code deletes all hyperlinks from document:

Sub DeleteHyperlinks()
Sub DeleteHyperLinks()
    Dim h As Hyperlink
    For Each h In ActiveDocument.Hyperlinks
        h.Delete
    Next
End Sub

The following VBA code deletes all hyperlinks from document:

Sub DeleteHyperlinks()
    Dim doc As Document
    Dim hyp As Hyperlink
    Dim i As Integer
    Dim max As Integer
    
    max = ActiveDocument.Hyperlinks.Count
    On Error Resume Next
    For i = 1 To max
        ActiveDocument.Hyperlinks(i).Delete
    Next
End Sub

The following VBA code deletes all hyperlinks from document:

Sub DeleteHyperlinkText()
    Dim h As Hyperlink
    Dim rng As Range
    ' Loop backwards to avoid collection shifting
    Dim i As Long
    For i = ActiveDocument.Hyperlinks.Count To 1 Step -1
        Set h = ActiveDocument.Hyperlinks(i)
        Set rng = h.Range
        rng.Delete
    Next i
End Sub

The following VBA code deletes all hyperlinks with its text from document:

Sub DeleteLinesWithHyperlinkContainingQuestion()
    Dim para As Paragraph
    Dim hLink As Hyperlink
    
    ' Loop through paragraphs backward to avoid index issues while deleting
    Dim i As Long
    For i = ActiveDocument.Paragraphs.Count To 1 Step -1
        Set para = ActiveDocument.Paragraphs(i)
        
        ' Check if any hyperlink in this paragraph contains "Question"
        For Each hLink In para.Range.Hyperlinks
            If InStr(1, hLink.TextToDisplay, "Question", vbTextCompare) > 0 Then
                para.Range.Delete
                Exit For ' Exit inner loop after deletion to avoid error
            End If
        Next hLink
    Next i
End Sub

The following VBA code deletes all hyperlinks with its text from document:

Sub DeleteParagraphsWithHyperlinkedQuestionUsingFind()
    Dim rng As Range
    Set rng = ActiveDocument.Content
    
    With rng.Find
        .ClearFormatting
        .Text = "Question[0-9]{1,}"
        .MatchWildcards = True
        .Forward = True
        .Wrap = wdFindStop
        
        Do While .Execute
            ' Check if found text is part of a hyperlink
            If rng.Hyperlinks.Count > 0 Then
                rng.Paragraphs(1).Range.Delete
            Else
                rng.Collapse Direction:=wdCollapseEnd
            End If
        Loop
    End With
End Sub

VBA Word - Delete pages of document between a range

The following VBA code deletes pages of Word document between a range.

Sub DeletePagesXtoY()
    Dim startRange As Range
    Dim endRange As Range
    Dim iStart As Integer
    Dim iEnd As Integer
    iStart = 249
    iEnd = 257
    
    Set startRange = ActiveDocument.GoTo(What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=iStart)
    ' Set the start of page 291
    Set endRange = ActiveDocument.GoTo(What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=iEnd)

    ' Select the range between page 230 and 290
    startRange.SetRange Start:=startRange.Start, End:=endRange.Start

    ' Delete the selected range
    startRange.Delete
End Sub

VBA Word - Adjust all images in Word document

The following VBA code adjusts images in Word document:

Sub AdjustImageSize()
    Dim doc As Document
    Dim img As InlineShape
    Dim shape As shape
    Dim docWidth As Single

    Set doc = ActiveDocument
    docWidth = doc.PageSetup.PageWidth - doc.PageSetup.LeftMargin - doc.PageSetup.RightMargin

    ' Loop through all inline shapes (embedded images)
    For Each img In doc.InlineShapes
        If img.Width > docWidth Then
            img.LockAspectRatio = msoTrue
            img.Width = docWidth
        End If
    Next img

    ' Loop through all floating shapes (floating images)
    For Each shape In doc.Shapes
        If shape.Type = msoPicture Or shape.Type = msoLinkedPicture Then
            If shape.Width > docWidth Then
                shape.LockAspectRatio = msoTrue
                shape.Width = docWidth
            End If
        End If
    Next shape
End Sub

VBA Word - Adjust Table alignment in middle of document

The following VBA code adjusts table alignment in middle of document:

Sub AdjustTableWidths()
    Dim doc As Document
    Dim tbl As Table
    Dim tblWidth As Single
    Dim docWidth As Single

    Set doc = ActiveDocument
    docWidth = doc.PageSetup.PageWidth - doc.PageSetup.LeftMargin - doc.PageSetup.RightMargin

    For Each tbl In doc.Tables
        tblWidth = tbl.PreferredWidth

        If tblWidth > docWidth Then
            tbl.PreferredWidth = docWidth
            tbl.AllowAutoFit = False ' Prevent autofit to ensure width stays as set
            ' Optionally, you can adjust column widths proportionally
            Dim col As Column
            Dim totalColWidth As Single
            totalColWidth = 0

            ' Calculate total width of columns
            For Each col In tbl.Columns
                totalColWidth = totalColWidth + col.Width
            Next col

            ' Adjust each column proportionally
            For Each col In tbl.Columns
                col.Width = col.Width * docWidth / totalColWidth
            Next col
        End If
    Next tbl
End Sub

VBA Word - Create Table Grid

The following VBA code generates table grid in Word document:

Sub TableGridDesignMacro()

   For Each Table In ActiveDocument.Tables
    Table.Style = "Table Grid"
   Next

End Sub

Home

Saturday, May 10, 2025

Wednesday, April 30, 2025

Tuesday, April 29, 2025

Monday, April 28, 2025

Thursday, January 16, 2025

Tuesday, December 24, 2024

Hot Topics