VBA Word Resize all images of document proportionately

VBA Word code which resizes all images of the document proportionately so that they all fit inside the document. You can keep width of images 80% or some other percentage of width of the document width.

Sub ResizeAllImages()
    Dim shp As InlineShape
    Dim fshp As Shape
    Dim doc As Document
    Dim pageWidth As Single
    Dim marginWidth As Single
    Dim usableWidth As Single
    Dim targetWidth As Single
    
    Set doc = ActiveDocument
    
    ' Calculate usable width (page width minus left and right margins)
    pageWidth = doc.PageSetup.PageWidth
    marginWidth = doc.PageSetup.LeftMargin + doc.PageSetup.RightMargin
    usableWidth = pageWidth - marginWidth
    
    ' Set target width = 80% of usable width
    targetWidth = usableWidth * 0.8
    
    ' Loop through inline shapes (images inside text)
    For Each shp In doc.InlineShapes
        If shp.Type = wdInlineShapePicture Or shp.Type = wdInlineShapeLinkedPicture Or shp.Type = wdInlineShapeEmbeddedOLEObject Then
            ' Resize proportionally
            shp.LockAspectRatio = msoTrue
            If shp.Width > targetWidth Then
                shp.Width = targetWidth
            End If
        End If
    Next shp
    
    ' Loop through floating shapes (images not inline)
    For Each fshp In doc.Shapes
        If fshp.Type = msoPicture Or fshp.Type = msoLinkedPicture Then
            ' Resize proportionally
            fshp.LockAspectRatio = msoTrue
            If fshp.Width > targetWidth Then
                fshp.Width = targetWidth
            End If
        End If
    Next fshp
    
    MsgBox "All images resized to max width = 80% of document width.", vbInformation
End Sub

VBA Word Extract and Reverse Blocks of paragraphs in Word document

Extract and Reverse "Prompted" Blocks in Word using VBA Macro

🧩 What This Macro Does

This VBA macro is designed for Microsoft Word documents that contain multiple occurrences of a keyword such as "Prompted". It automatically:

1. Searches from bottom to top of the document.

2. Each time it finds a line containing the word "Prompted", it:

   • Selects from that line to the end of the document,

   • Cuts the block,

   • Pastes it at the end of a new document.

3. This process continues until no more "Prompted" entries are found.

4. The result is a new Word document with all such blocks extracted in reversed order (i.e., last occurrence first).

5. The new document is saved:

   • In the same folder as the source file,

   • With a timestamped filename like:
     OriginalName_reversed_20250806_162530.docx

6. Finally, the original document is closed without saving any changes, keeping your source document untouched.

---

⚙️ Use Case Examples

• Reorganizing structured logs or notes in reverse or Gemini Chats copied in MS-Word

• Extracting repeated section-based content like surveys or prompted responses.

• Working with very large documents (e.g., 1000+ pages) efficiently.

---

🚀 Code

Sub ExtractPromptedBlocks_TrueReverse_SaveTimestamped_CloseOriginal()

    Dim docSource As Document
    Dim docTarget As Document
    Dim rngSearch As Range
    Dim rngCut As Range
    Dim findText As String
    Dim sourcePath As String
    Dim sourceName As String
    Dim savePath As String
    Dim timestamp As String

    ' Reference the active (source) document
    Set docSource = ActiveDocument
    Set docTarget = Documents.Add

    findText = "Prompted"

    ' Start from the end of the document
    Set rngSearch = docSource.Content
    rngSearch.Collapse Direction:=wdCollapseEnd

    ' Loop to cut "Prompted" blocks from bottom to top
    Do
        rngSearch.Find.ClearFormatting
        With rngSearch.Find
            .Text = findText
            .Forward = False
            .MatchCase = False
            .Wrap = wdFindStop
        End With

        If rngSearch.Find.Execute Then
            Set rngCut = docSource.Range(rngSearch.Paragraphs(1).Range.Start, docSource.Content.End)
            rngCut.Cut

            With docTarget.Content
                .Collapse Direction:=wdCollapseEnd
                .Paste
                .InsertParagraphAfter
            End With

            Set rngSearch = docSource.Range(0, rngSearch.Paragraphs(1).Range.Start)
        Else
            Exit Do
        End If
    Loop

    ' Prepare timestamp for unique filename
    timestamp = Format(Now, "_reversed_yyyymmdd_HHmmss")
    
    ' Build full save path
    sourcePath = docSource.Path
    sourceName = Left(docSource.Name, InStrRev(docSource.Name, ".") - 1)
    savePath = sourcePath & Application.PathSeparator & sourceName & timestamp & ".docx"

    ' Save new document with timestamped name
    docTarget.SaveAs2 FileName:=savePath, FileFormat:=wdFormatXMLDocument

    ' Close original document WITHOUT saving
    docSource.Close SaveChanges:=wdDoNotSaveChanges

    MsgBox "Done! Reversed content saved as:" & vbCrLf & savePath, vbInformation

End Sub

---

🚀 Benefits

• Fully automated and repeatable

• Works even with massive documents

• Prevents accidental overwrites using timestamped filenames

• Non-destructive to the original document

---

🧠 To Use the Macro

1. Open the Word document.

2. Press Alt + F11 to open the VBA Editor.

3. Insert a new module and paste the macro code.

4. Run the macro using Alt + F8.

---

This macro saves hours of manual effort and ensures accurate, clean extraction of structured content in reverse order. Ideal for professionals working with large, templated Word documents.

---