MS Word Vba how can I loop through a document selecting each paragraph with any graphics it may contain floating or inline

Hi,

you don't have to refer to all paragraphs

you can access the images directly

Sub Images()
Dim Image As InlineShape
Dim Shp As Shape

    For Each Image In ActiveDocument.InlineShapes
        If Image.Type = wdInlineShapePicture Then
            'Do it here
        End If
    Next
    For Each Shp In ActiveDocument.Shapes
        If Shp.Type = msoLinkedPicture Then
            'Do it here
        End If
    Next

End Sub

Select allOpen in new window

EDIT added Shapes
Regards

Thanks but I actually want to take separate screenshots of each indivdual paragraph with the graphics it contains and save it to file

pls try

Sub LoopThroughParagraphs()

Dim objFSO, strFolder
strTempFolder = ActiveDocument.Path & "\Temp\"
Set objFSO = CreateObject("Scripting.FileSystemObject")
If Not objFSO.FolderExists(strTempFolder) Then
   objFSO.CreateFolder (strTempFolder)
End If
Dim Para As Paragraph
Rmargin = PointsToCentimeters(Selection.PageSetup.RightMargin)
LMargin = PointsToCentimeters(Selection.PageSetup.LeftMargin)
PWidth = PointsToCentimeters(Selection.PageSetup.PageWidth)

IdxPara = 1

For Each Para In ThisDocument.Paragraphs

    
    Set objDoc1 = Documents.Add
    Para.Range.Select
    If Asc(Para.Range.Text) <> 13 Then
        Selection.Copy
        objDoc1.Select
        Selection.Paste
        Selection.MoveLeft Unit:=wdCharacter, Count:=1
        CurPos = PointsToCentimeters(Max(36, Selection.Information(wdHorizontalPositionRelativeToPage) - Selection.PageSetup.LeftMargin))
    
        NewRMargin = (PWidth - LMargin) - CurPos - 0.1
        Selection.PageSetup.RightMargin = CentimetersToPoints(NewRMargin)
        Selection.HomeKey Unit:=wdLine, Extend:=wdExtend
            Selection.Copy
        Selection.PasteSpecial Link:=False, DataType:=wdPasteEnhancedMetafile, _
            Placement:=wdInLine, DisplayAsIcon:=False
        Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
        docName1 = ThisDocument.Name
        docName2 = Left(docName1, InStr(1, docName1, ".") - 1) & "_Paragraph" & Format(IdxPara, "0000") & ".htm"
        docName3 = strTempFolder & docName2
        ActiveDocument.SaveAs FileName:=docName3, FileFormat:=wdFormatHTML
        objDoc1.Close wdDoNotSaveChanges
        ImageSearch = strTempFolder & Left(docName2, Len(docName2) - 4) & "-Dateien\*.png"
        ImageFile = Dir(ImageSearch)
        OldName = strTempFolder & Left(docName2, Len(docName2) - 4) & "-Dateien\" & ImageFile
        NewName = strTempFolder & Left(docName2, Len(docName2) - 4) & ".png"
        Name OldName As NewName
        Kill strTempFolder & "\*.htm"
        strFolderSpec = strTempFolder & Left(docName2, Len(docName2) - 4) & "-Dateien"
        If objFSO.FolderExists(strFolderSpec) Then
            objFSO.DeleteFolder strFolderSpec, blnForce
            KillSubFolders = True
        End If
        IdxPara = IdxPara + 1
    Else
        objDoc1.Close wdDoNotSaveChanges
    End If
Next Para

End Sub


Function Max(Var1, Var2)
If Var1 > Var2 Then
 Max = Var1
Else
 Max = Var2
End If

End Function

Select allOpen in new window

wow! That is a huge hunk of code . Thank you so much! May you be blessed with all good things. After you put in so much effort I hate to bother you about this I am sorry to bother you bit the dir command acts very strangely on my computer and perhaps that is why I am getting a strange error code on line 44 Name OldName As NewName
i get error Runtime erroe '53' file not found now when I looked in the variable ImageFile it was emptey. Sorry tot trouble you thanks for everything

Thank you so much for your hard work I am away until monday I hope its ok for me to test it then. I apologize for the delay. Thankyou so so much