VBA code to copy images from source Word document to a new Word document

Use case: I have a few png/jpeg images that I wish to copy over from a source document to a new document.

I have put together the following code to achieve this objective. However, in my new document all I see copied over is the last image from the source document.

What am I missing here please:

Sub CopyFiguresToNewDocument()
    Dim sourceDoc As Document
    Set sourceDoc = ActiveDocument
    
    ' Create a new document
    Dim newDoc As Document
    Set newDoc = Documents.Add
    
    ' Iterate through the shapes in the source document
    Dim inlineshape As inlineshape
    For Each inlineshape In sourceDoc.InlineShapes
        ' Check if the shape is a figure (e.g., picture, chart, etc.)
        If inlineshape.Type = wdInlineShapePicture Then
            ' Copy the figure to the new document
            inlineshape.Select
            Selection.Copy
            newDoc.Range.Paste
            newDoc.Range.InsertParagraphAfter ' Add a paragraph break after each figure
        End If
    Next inlineshape
    
    ' Save and close the new document
    ' Modify the path and filename as desired
    newDoc.SaveAs2 "C:\Users\xyz\Desktop\NewDocument.docx"
    newDoc.Close
    
    MsgBox "Figures copied to the new document."
End Sub

This corrected code works on my test document:

Sub CopyFiguresToNewDocument()
    Dim sourceDoc As Document
    Set sourceDoc = ActiveDocument
    
    ' Create a new document
    Dim newDoc As Document
    Set newDoc = Documents.Add
    
    ' Iterate through the shapes in the source document
    Dim s As inlineshape
    For Each s In sourceDoc.InlineShapes
        ' Check if the shape is a figure (e.g., picture, chart, etc.)
        If s.Type = wdInlineShapePicture Then
            ' Copy the figure to the new document
            s.Select
            Selection.Copy
            newDoc.Range(newDoc.Content.End - 1).Paste
            newDoc.Range.InsertParagraphAfter ' Add a paragraph break after each figure
        End If
    Next
    
    ' Save and close the new document
    ' Modify the path and filename as desired
    newDoc.SaveAs2 "C:\Users\H182720\Desktop\NewDocument.docx"
    newDoc.Close
    
    MsgBox "Figures copied to the new document."
End Sub

Note the line newDoc.Range(newDoc.Content.End - 1).Paste: this will paste it at the end of the current content, instead of replacing the whole content as your original code.

Your code fails because newDoc.Range represents the entire content of the document, so each iteration of the loop simply replaces the existing content.

There is no need to select anything in either document, nor is there any need to use the clipboard. The following code will put the pictures at the end of a new document.

Sub CopyFiguresToNewDocument()
    Dim sourceDoc As Document
    Set sourceDoc = ActiveDocument
    
    ' Create a new document
    Dim newDoc As Document
    Set newDoc = Documents.Add
    
    ' Iterate through the shapes in the source document
    Dim s As InlineShape
    For Each s In sourceDoc.InlineShapes
        ' Check if the shape is a figure (e.g., picture, chart, etc.)
        If s.Type = wdInlineShapePicture Then
            ' Copy the figure to the new document
            newDoc.Characters.Last.FormattedText = s.Range.FormattedText
            newDoc.Range.InsertParagraphAfter ' Add a paragraph break after each figure
        End If
    Next
    
    ' Save and close the new document
    ' Modify the path and filename as desired
    newDoc.SaveAs2 "C:\Users\H182720\Desktop\NewDocument.docx"
    newDoc.Close
    
    MsgBox "Figures copied to the new document."
End Sub

Sub CopyImagesToNewDocument()
    Dim srcDoc As Document
    Dim newDoc As Document
    Dim srcShape As Shape
    Dim newShape As Shape
    
    ' Open the source document
    Set srcDoc = Documents.Open("C:\Path\To\SourceDocument.docx")
    
    ' Create a new document
    Set newDoc = Documents.Add
    
    ' Loop through each shape in the source document
    For Each srcShape In srcDoc.Shapes
        ' Check if the shape is an image
        If srcShape.Type = msoPicture Then
            ' Copy the image to the new document
            srcShape.Select
            Selection.Copy
            
            ' Paste the image in the new document
            newDoc.Range.Paste
            Set newShape = newDoc.Shapes(newDoc.Shapes.Count)
            
            ' Adjust the position and size of the image if needed
            ' For example:
            newShape.Left = 100
            newShape.Top = 100
            newShape.LockAspectRatio = msoFalse
            newShape.Width = 200
            newShape.Height = 200
        End If
    Next srcShape
    
    ' Save and close the new document
    newDoc.SaveAs "C:\Path\To\NewDocument.docx"
    newDoc.Close
    
    ' Close the source document
    srcDoc.Close
End Sub