Word Macro VBA | Insert images one by one, page by page

[leonelcd]

Hi.



I want to populate a Word document with images obtained from a specific folder and insert them one by one page by page.

My code gives me the first part (getting images from a specific folder), but it fails miserably at placing them image by image, page by page, because it ends up placing some images spaced out and others, for some reason I don't know, it adds several on top of each other at the end of the document (!!).

I've tried everything and the closest I've come is the code reproduced below. I'm also showing an image that gives you a better idea of the mess the images in the document are in.



The code:

Sub Insert_Images_Bilder_Import() 
    Dim Path As String 
    Dim fs As Object 
    Dim ff As Variant 
    Dim Img As Variant 
    Dim i As Long 
    Dim fsize As Long 
    Dim Shp As shape 
    Dim Rng As Range 
    Path = "C:\Users\L\Pictures" 
    Set fs = CreateObject("Scripting.FileSystemObject") 
    Set ff = fs.GetFolder(Path).Files 
    i = 0 
    fsize = ff.count       
    With ActiveDocument 
        For Each Img In ff 
            Select Case Right(Img.Name, 4) 
                Case ".bmp", ".jpg", ".gif", ".png" 
                    i = i + 1 
                    Set Shp = ActiveDocument.shapes.AddPicture(FileName:=Img, _ 
                    LinkToFile:=False, SaveWithDocument:=True, Width:=CentimetersToPoints(18), Height:=CentimetersToPoints(25), Anchor:=Selection.Range)                                        
                    With Shp 
                        .LockAspectRatio = False 
                        .RelativeHorizontalPosition = wdRelativeHorizontalPositionMargin 
                        .RelativeVerticalPosition = wdRelativeVerticalPositionMargin 
                        .RelativeHorizontalSize = wdRelativeHorizontalSizeMargin 
                        .RelativeVerticalSize = wdRelativeVerticalSizeMargin 
                        .Left = wdShapeCenter 
                        .LeftRelative = wdShapePositionRelativeNone 
                        .Top = wdShapeTop 
                        .TopRelative = wdShapePositionRelativeNone 
                        .WidthRelative = wdShapeSizeRelativeNone 
                        .HeightRelative = wdShapeSizeRelativeNone 
                        .LockAnchor = False 
                        .LayoutInCell = True 
                        .WrapFormat.AllowOverlap = True 
                        .WrapFormat.Side = wdWrapBoth
                        .WrapFormat.DistanceTop = MillimetersToPoints(0) 
                        .WrapFormat.DistanceBottom = MillimetersToPoints(0)
                        .WrapFormat.DistanceLeft = MillimetersToPoints(120) 
                        .WrapFormat.DistanceRight = MillimetersToPoints(120) 
                        .WrapFormat.Type = wdWrapTight 
                        .Line.Visible = True 
                        .Line.Style = msoLineSingle 
                        .Line.Weight = 0.5 
                        .Line.ForeColor.RGB = RGB(102, 51, 0)                                            
                    End With            
[Here begins my problem!]    
                    Selection.TypeParagraph 
                    Selection.Collapse Direction:=wdCollapsEnd 
                    Selection.InsertBreak Type:=wdPageBreak 
                End Select 
        Next      
    End With 
    Application.ScreenUpdating = True 
End Sub

Thank you for your assistance!