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

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

1. The pathname can include a directory and drive.
2. If the pathname cannot be found, a zero-length string ("") is returned.
3. The attributes parameter can be a constant or a numerical expression.
• If omitted, 0 is used, representing files matching the pathname with no attributes.
4. Wildcard characters:
• * (matches zero or more characters)
• ? (matches any single character)
5. To iterate over all files in a folder, specify an empty string ("") for the pathname.
6. First call to DIR requires a pathname. Subsequent calls can omit it to retrieve additional matching file names.
7. When no more files exist, an empty string is returned.
8. File names are not returned in a particular order. To display them in order, consider storing them in an array and sorting them.
9. The vbAlias and vbVolume attributes are only available on Macintosh.
10. Recursive calls to the DIR function are not allowed.
11. If attributes > 256, it is assumed to be a MacID value.
12. Use DIR$ to return a String data type instead of a Variant/String.
13. The MKDIR function can create new directories.
14. For SharePoint paths, use forward slashes (/) instead of backslashes (\) between subfolders.
15. 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

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

VBA Word - Split Word Document of Large size and Many Pages

The following VBA code splits word document into two equal parts.

Sub SplitWordDocumentWithoutOpening()
    Dim appWord As Object
    Dim doc As Object
    Dim newDoc As Object
    Dim totalPages As Long
    Dim startPage As Long
    Dim splitPoint As Long
    Dim rng As Object
    Dim strDocumentPath As String
    Dim strOutputPath As String
    
    strDocumentPath = "G:\Word Documents\1\a1234.docx"
    strOutputPath = "G:\Word Documents"
    ' Create a Word application object (invisible)
    Set appWord = CreateObject("Word.Application")
    appWord.Visible = False

    ' Open the Word document
    Set doc = appWord.Documents.Open(strDocumentPath)
    
    ' Get total pages
    totalPages = doc.ComputeStatistics(wdStatisticPages)
    
    ' Define the split point (e.g., after half the pages)
    splitPoint = totalPages \ 2
    startPage = splitPoint + 1

    ' Copy pages from the split point to the end to a new document
    Set rng = doc.GoTo(What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=startPage)
    Set rng = doc.Range(rng.Start, doc.Content.End)

    ' Create and save a new document for the second part
    Set newDoc = appWord.Documents.Add
    newDoc.Content.FormattedText = rng.FormattedText
    newDoc.SaveAs2 strOutputPath & "\Part2.docx"
    
    ' Remove the copied pages from the original document and save it
    rng.Delete
    doc.SaveAs2 strOutputPath & "\Part1.docx"

    ' Close documents and Word application
    newDoc.Close
    doc.Close
    appWord.Quit
    
    MsgBox "Document split successfully.", vbInformation
End Sub

VBA Word - Delete lines which contain specific text

The following VBA code deletes all lines from Word document which contain "Copy code" text. It also deletes the line before the text. Effectively, it deletes 2 lines in each iteration:

Sub DeleteLineBeforeAndContainingCopyCode()
    Dim doc As Document
    Dim currentPosition As Long
    Dim findRange As Range
    Dim deleteRange As Range

    ' Set the document
    Set doc = ActiveDocument

    ' Start from the bottom of the document
    currentPosition = doc.Content.End

    ' Loop until the top of the document
    Do While currentPosition > 0
        ' Set a range starting from the current position
        Set findRange = doc.Range(Start:=0, End:=currentPosition)

        ' Find the "Copy code" text
        With findRange.Find
            .Text = "Copy code"
            .Forward = False ' Search upwards
            .Wrap = wdFindStop
            .Format = False
            .MatchCase = False
            .MatchWholeWord = False
        End With

        If findRange.Find.Execute Then
            ' Create a range to delete the current and previous lines
            Set deleteRange = doc.Range(Start:=findRange.Paragraphs(1).Range.Start, _
                                        End:=findRange.Paragraphs(1).Range.End)

            ' Include the line above if it exists
            If findRange.Start > doc.Range.Start Then
                deleteRange.Start = deleteRange.Start - 1
                deleteRange.Start = deleteRange.Paragraphs(1).Range.Start
            End If

            ' Delete the range
            deleteRange.Delete

            ' Update the current position
            currentPosition = findRange.Start
        Else
            ' Exit the loop if "Copy code" is not found
            Exit Do
        End If
    Loop
    MsgBox "Done"
End Sub

VBA PowerPoint to Create Microsoft Presentation from Text File

Objectives:

The purpose of this VBA PowerPoint code is to automate the process of exporting paragraphs from a Text file into a PowerPoint presentation. Each paragraph is transformed into a separate slide, with the option to include a title and a company logo. The text file path and logo image is hard coded; these can be modified as per the need. The code is as follows:

Sub CreatePresentationFromTextFile()
    Dim pptApp As Object
    Dim pptPres As Object
    Dim slideIndex As Integer
    Dim slide As Object
    Dim textFileName As String
    Dim fileNumber As Integer
    Dim lineContent As String
    Dim logoPath As String
    Dim logoShape As Object
    Dim slideWidth As Single
    Dim logoWidth As Single
    Dim logoHeight As Single
    
    ' Set the path to your text file and logo
    textFileName = "C:\Users\ajeet\Documents\test.txt" ' Change to your text file path
    logoPath = "G:\# Pictures\Image Common\logo.png" ' Change to your logo image path
    
    ' Logo size in inches (convert inches to points, 1 inch = 72 points)
    logoWidth = 1.13 * 72
    logoHeight = 1.13 * 72
    
    ' Create a new PowerPoint application and presentation
    Set pptApp = CreateObject("PowerPoint.Application")
    Set pptPres = pptApp.Presentations.Add
    pptApp.Visible = True
    
    ' Get slide width for logo positioning
    slideWidth = pptPres.PageSetup.SlideWidth
    
    ' Open the text file for reading
    fileNumber = FreeFile
    Open textFileName For Input As fileNumber
    
    ' Initialize slide index
    slideIndex = 1
    
    ' Read each line from the text file
    Do While Not EOF(fileNumber)
        Line Input #fileNumber, lineContent
        
        ' Check if the line content is not empty or blank
        If Trim(lineContent) <> "" Then
            ' Add a new slide with Title and Content layout
            Set slide = pptPres.Slides.Add(slideIndex, ppLayoutText)
            
            ' Set the title of the slide (you can customize this as needed)
            slide.Shapes(1).TextFrame.TextRange.Text = "Slide " & slideIndex
            
            ' Set the content of the slide (using Hindi font)
            With slide.Shapes(2).TextFrame.TextRange
                .Text = lineContent
                .Font.Name = "Mangal" ' You can change this to the preferred Hindi font
                .Font.Size = 15 ' Adjust font size as per your need
            End With
            
            ' Add the logo to the slide in the top right corner
            Set logoShape = slide.Shapes.AddPicture(logoPath, _
                            msoFalse, msoCTrue, slideWidth - logoWidth - 10, 10, logoWidth, logoHeight)
            
            ' Increment slide index for the next slide
            slideIndex = slideIndex + 1
        End If
    Loop
    
    ' Close the text file
    Close fileNumber
    
    ' Clean up
    Set slide = Nothing
    Set pptPres = Nothing
    Set pptApp = Nothing
End Sub

VBA Code for Exporting Word Paragraphs to PowerPoint

Objective

The purpose of this VBA code is to automate the process of exporting paragraphs from a Microsoft Word document into a PowerPoint presentation. Each paragraph is transformed into a separate slide, with the option to include a title and a company logo. Additionally, the PowerPoint file is saved in a specified folder on the Desktop, with a unique filename that incorporates the current date and time.

Sub ExportParagraphsToPowerPoint()
    Dim PPTApp As Object
    Dim PPTPresentation As Object
    Dim PPTSlide As Object
    Dim PPTShape As Object
    Dim WordParagraph As Paragraph
    Dim SlideText As String
    Dim SlideTitle As String
    Dim SlideWidth As Single
    Dim SlideHeight As Single
    Dim LogoPath As String
    Dim TitleShape As Object
    Dim LogoShape As Object
    Dim DesktopPath As String
    Dim FolderPath As String
    Dim PPTFilePath As String
    Dim CurrentDateTime As String
    
    ' Define the path to your company logo image
    LogoPath = "C:\Users\ajeet\Desktop\Appliedk\logo.png"
    
    ' Get the path to the Desktop
    DesktopPath = CreateObject("WScript.Shell").SpecialFolders("Desktop")
    FolderPath = DesktopPath & "\WordPpt" ' Folder where the PPT will be saved

    ' Check if folder exists, if not, create it
    If Dir(FolderPath, vbDirectory) = "" Then
        MkDir FolderPath
    End If
    
    ' Create a formatted date and time string for the filename
    CurrentDateTime = Format(Now, "yyyy-mm-dd_hh-nn-ss")
    
    ' Set the full path for saving the PowerPoint file
    PPTFilePath = FolderPath & "\ExportedPPT_" & CurrentDateTime & ".pptx"

    ' Create a new instance of PowerPoint (Make PowerPoint invisible during processing)
    On Error Resume Next
    Set PPTApp = GetObject(, "PowerPoint.Application")
    If PPTApp Is Nothing Then
        Set PPTApp = CreateObject("PowerPoint.Application")
    End If
    PPTApp.Visible = False ' Make PowerPoint invisible during processing
    On Error GoTo 0
    
    ' Create a new PowerPoint presentation
    Set PPTPresentation = PPTApp.Presentations.Add

    ' Get slide dimensions for reference
    SlideWidth = PPTPresentation.PageSetup.SlideWidth
    SlideHeight = PPTPresentation.PageSetup.SlideHeight

    ' Loop through each paragraph in the Word document
    For Each WordParagraph In ActiveDocument.Paragraphs
        SlideText = WordParagraph.Range.Text
        ' Remove any extra line breaks or spaces from the paragraph text
        SlideText = Trim(SlideText)
        
        ' Check if the paragraph contains text (skip empty paragraphs)
        If Len(SlideText) > 0 Then
            ' Add a new slide with a blank layout (layout ID 12)
            Set PPTSlide = PPTPresentation.Slides.Add(PPTPresentation.Slides.Count + 1, 12)
            
            ' Add a title at the top of the slide
            SlideTitle = "Slide " & PPTPresentation.Slides.Count ' You can customize the title format as needed
            Set TitleShape = PPTSlide.Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, _
                                                        Left:=50, Top:=20, Width:=SlideWidth - 100, Height:=50)
            TitleShape.TextFrame.TextRange.Text = SlideTitle
            With TitleShape.TextFrame.TextRange.Font
                .Name = "Arial" ' Change font style here
                .Size = 28      ' Set title font size
                .Bold = msoTrue ' Title in bold
            End With
            
            ' Set position and size of the text box (modify as needed)
            Dim textBoxLeft As Single
            Dim textBoxTop As Single
            Dim textBoxWidth As Single
            Dim textBoxHeight As Single
            
            ' Customize the position and size of the text box for the paragraph content
            textBoxLeft = 50       ' Distance from the left side (in points)
            textBoxTop = 100       ' Distance from the top (in points)
            textBoxWidth = 500     ' Width of the text box (in points)
            textBoxHeight = 300    ' Height of the text box (in points)
            
            ' Add the text box to the slide
            Set PPTShape = PPTSlide.Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, _
                                                      Left:=textBoxLeft, Top:=textBoxTop, _
                                                      Width:=textBoxWidth, Height:=textBoxHeight)
                                                      
            ' Add paragraph text to the text box
            PPTShape.TextFrame.TextRange.Text = SlideText
            
            ' Set font size and style for paragraph text
            With PPTShape.TextFrame.TextRange.Font
                .Name = "Arial" ' Change font style here
                .Size = 24      ' Set paragraph font size
                .Bold = msoFalse ' Optional: remove bold
            End With
            
            ' Add the company logo to the top-right corner
            Dim logoLeft As Single
            Dim logoTop As Single
            Dim logoWidth As Single
            Dim logoHeight As Single
            
            ' Set the position and size for the logo
            logoWidth = 100    ' Adjust width of logo
            logoHeight = 100   ' Adjust height of logo
            logoLeft = SlideWidth - logoWidth - 20 ' Positioned 20 points from the right
            logoTop = 20       ' Positioned 20 points from the top
            
            ' Add the logo image to the slide
            Set LogoShape = PPTSlide.Shapes.AddPicture(LogoPath, _
                                                       LinkToFile:=msoFalse, _
                                                       SaveWithDocument:=msoTrue, _
                                                       Left:=logoLeft, Top:=logoTop, _
                                                       Width:=logoWidth, Height:=logoHeight)
        End If
    Next WordParagraph
    
    ' Save the PowerPoint file in the "WordPpt" folder on the Desktop
    PPTPresentation.SaveAs PPTFilePath
    
    ' Close the PowerPoint presentation
    PPTPresentation.Close
    
    ' Cleanup
    Set PPTShape = Nothing
    Set PPTSlide = Nothing
    Set PPTPresentation = Nothing
    PPTApp.Quit ' Close PowerPoint
    Set PPTApp = Nothing
    
    ' Display "Done PPT" message
    MsgBox "Done PPT", vbInformation
End Sub 

Code Breakdown

1. Variable Declarations:

   • The code begins by declaring various objects and variables, including:
     • PPTApp: The PowerPoint application object.
     • PPTPresentation: The PowerPoint presentation object.
     • PPTSlide: Represents individual slides within the presentation.
     • PPTShape: Represents shapes (text boxes) on the slides.
     • WordParagraph: Represents each paragraph in the Word document.
     • Other variables for text, dimensions, logo path, and file paths.

2. Logo and Path Setup:

   • The path to the company logo image is defined with LogoPath.
   • The desktop path is retrieved using WScript.Shell to create a folder named WordPpt for saving the PowerPoint file.
   • If the folder does not exist, it is created using MkDir.

3. File Naming:

   • The current date and time are formatted into a string (CurrentDateTime) to ensure a unique filename. This avoids overwriting previous files.

4. PowerPoint Application Handling:

   • The code attempts to get an existing instance of PowerPoint. If not found, it creates a new instance.
   • The PowerPoint application is set to be invisible during the processing (PPTApp.Visible = False) to enhance user experience.

5. Presentation Creation:

   • A new PowerPoint presentation is created using PPTApp.Presentations.Add.

6. Looping Through Word Paragraphs:

   • The code iterates through each paragraph in the active Word document using a For Each loop.
   • It trims any leading or trailing spaces from the paragraph text and checks if it is non-empty.
   • For each valid paragraph, a new slide is added to the presentation with a blank layout.

7. Adding Title and Content:

   • A title is added to each slide, formatted with specific font settings (e.g., Arial, size 28, bold).
   • A text box is created for the paragraph content, with customizable dimensions and font settings (e.g., Arial, size 24).
   • The text box is positioned within the slide based on specified left, top, width, and height parameters.

8. Adding Company Logo:

   • The logo is added to the top-right corner of each slide, with customizable dimensions and positioning.

9. Saving the Presentation:

   • The PowerPoint presentation is saved to the WordPpt folder on the Desktop, using the generated filename that includes the date and time.

10. Cleanup and Closure:

    • The code cleans up by closing the PowerPoint presentation and quitting the PowerPoint application.
    • Finally, a message box is displayed to notify the user that the process is complete with the message "Done PPT".

Conclusion

This VBA code provides an efficient way to convert paragraphs from a Word document into a structured PowerPoint presentation, enhancing productivity for users who frequently create presentations from text content. The ability to customize titles, text formatting, and logo placement adds further utility, while the automatic file naming prevents data loss from overwriting.

VBA - FileSystemObject Properties and Methods

Properties and Methods of the FileSystemObject Object

Description

Property/Method

BuildPath()

Appends information to a file path

CopyFile()

Copies a file from one location to another

CopyFolder()

Copies a folder from one location to another

CreateFolder()

Creates a new folder object

CreateTextfile()

Creates a new text file object

DeleteFile()

Removes a file

DeleteFolder()

Removes a folder object

DriveExists()

Determines whether a drive exists

Drives

Returns a Drives collection, containing all the available drive objects

FileExists()

Determines whether a file exists

FolderExists()

Determines whether a folder exists

GetAbsolutePathName()

Returns the absolute pathname for a file

GetBaseName()

Gets the base name of the last component

GetDrive()

Gets the drive letter for a file

GetDriveName()

Gets the drive name on which a file resides

ExtensionName()

Returns the extension for a file

GetFile()

Gets the file object

GetFileName()

Gets the name of a file

GetFolder()

Gets the folder name that contains a file

GetParentFolderName()

Gets the parent folder's name

GetSpecialFolder()

Gets the folder names for special folders

GetTempName()

Creates a randomly generated temporary file

MoveFile()

Moves a file from one location to another

MoveFolder()

Moves a folder and its contents from one location to another

OpentextFile()

Opens a text file stream to a file