Tuesday, 23 July 2019

VBA Code to insert mutiple images in Microsoft Word



Use below code 

Sub PicturesWithCaption()
    Dim xFileDialog As FileDialog
    Dim xPath, xFile As Variant
    On Error Resume Next
    Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
    If xFileDialog.Show = -1 Then
        xPath = xFileDialog.SelectedItems.Item(1)
        If xPath <> "" Then
            xFile = Dir(xPath & "\*.*")
            Do While xFile <> ""
                If UCase(Right(xFile, 3)) = "PNG" Or _
                    UCase(Right(xFile, 3)) = "TIF" Or _
                    UCase(Right(xFile, 3)) = "JPG" Or _
                    UCase(Right(xFile, 3)) = "GIF" Or _
                    UCase(Right(xFile, 3)) = "BMP" Then
                    With Selection
                        .InlineShapes.AddPicture xPath & "\" & xFile, False, True
                        .InsertAfter vbCrLf
                        .MoveDown wdLine
                        .Text = xFile & Chr(10)
                        .MoveDown wdLine
                    End With
                End If
                xFile = Dir()
            Loop
        End If
    End If
End Sub



Posted by at

16 comments:

  1. L16 May 2020 at 16:59

    How Can I insert four photos in one page with this? Is it possible?
    Thanks for sharing this trick.

    ReplyDelete
  2. gary1 June 2020 at 12:49

    This worked beautifully for close to 70 images

    ReplyDelete
  3. word5 July 2020 at 03:00

    can you just help me write the name of the picture inside a text box ?

    ReplyDelete
  4. Naqash21 July 2020 at 09:21

    name coming at bottom is possible to put on Top of photo

    ReplyDelete
    Replies
    1. Techie28 July 2020 at 00:33

      Please use below code

      Sub PicturesWithCaption()
      Dim xFileDialog As FileDialog
      Dim xPath, xFile As Variant
      On Error Resume Next
      Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
      If xFileDialog.Show = -1 Then
      xPath = xFileDialog.SelectedItems.Item(1)
      If xPath <> "" Then
      xFile = Dir(xPath & "\*.*")
      Do While xFile <> ""
      If UCase(Right(xFile, 3)) = "PNG" Or _
      UCase(Right(xFile, 3)) = "TIF" Or _
      UCase(Right(xFile, 3)) = "JPG" Or _
      UCase(Right(xFile, 3)) = "GIF" Or _
      UCase(Right(xFile, 3)) = "BMP" Then
      With Selection
      .Text = xFile & Chr(10)
      .MoveDown wdLine
      .InlineShapes.AddPicture xPath & "\" & xFile, False, True
      .InsertAfter vbCrLf
      .MoveDown wdLine
      End With
      End If
      xFile = Dir()
      Loop
      End If
      End If
      End Sub

      Delete
  5. Sunny28 July 2020 at 15:39

    Hello Techie,

    Thank you so much for your help. It really saved me lots of time and effort so you have really done magic for me. One question, I wanted to paste 2 images per page, so I tried to increase the page layout margin but the image height was not making it possible. So please advise if there's way to paste two images per page. Thank you so much.

    ReplyDelete
  6. Unknown24 August 2020 at 20:54

    Hello Techie, This did not work for me and I am not sure why. I am on Microsoft 10 Office - my files are .jpg but when I go to the file, it doesn't show any images. This macro would really help me out!

    ReplyDelete
    Replies
    1. Ethan H7 April 2023 at 06:32

      Check if your images are actually .JPEG - in that case add this line:
      UCase(Right(xFile, 4)) = "JPEG" Or _

      Delete
  7. Monika20 September 2020 at 17:04

    Hello Techie,

    Can you help me with the code to update the images with the new images which are already there on the Microsoft word

    ReplyDelete
  8. AMM10 October 2021 at 20:50

    Hi, when I run.. it run until the select folder then after select folder, it look like processing for short while then it went to the VB module and stop... why?

    ReplyDelete
  9. Unknown29 November 2021 at 16:36

    This was easy and worked well for over 131 images. Thank you!

    ReplyDelete
  10. mbcoalson17 January 2022 at 13:45

    I would like to format the caption using the Insert Caption function in Word. My intention is to easily generate a table of figures at the beginning of the report.

    I believe this is leading me down the right track, but I haven't gotten it to work with your code yet -
    . InsertCaption( _Label_ , _Title_ , _TitleAutoText_ , _Position_ , _ExcludeLabel_ )
    https://docs.microsoft.com/en-us/office/vba/api/word.selection.insertcaption

    Ideally the TitleAutoText would auto populate with the file extension name, but exclude the file type.

    Whether or not you're able to help, thank you for providing the work you have already done!

    ReplyDelete
  11. mbcoalson17 January 2022 at 14:11

    I realized I could have been more precise. When I use the below code and try to generate a Table of Figures it also includes the photos. Any help is appreciated.

    Sub PicturesWithCaption()
    Dim xFileDialog As FileDialog
    Dim xPath, xFile As Variant
    On Error Resume Next
    Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
    If xFileDialog.Show = -1 Then
    xPath = xFileDialog.SelectedItems.Item(1)
    If xPath <> "" Then
    xFile = Dir(xPath & "\*.*")
    Do While xFile <> ""
    If UCase(Right(xFile, 3)) = "PNG" Or _
    UCase(Right(xFile, 3)) = "TIF" Or _
    UCase(Right(xFile, 3)) = "JPG" Or _
    UCase(Right(xFile, 3)) = "GIF" Or _
    UCase(Right(xFile, 3)) = "BMP" Then
    With Selection
    .InlineShapes.AddPicture xPath & "\" & xFile, False, True
    .InsertAfter vbCrLf
    .Collapse Direction:=wdCollapseStart
    .InsertCaption Label:="Figure", Title:=":", Position:=wdCaptionPositionBelow
    .Text = xFile & Chr(10)
    .MoveDown wdLine
    End With
    End If
    xFile = Dir()
    Loop
    End If
    End If

    ReplyDelete
    Replies
    1. Ethan H7 April 2023 at 06:58

      You will want to add the following line after .Collapse Direction:=wdCollapseStart:

      .MoveDown wdLine

      Delete
  12. Unknown22 February 2022 at 12:02

    Worked great and saved me masses of tiresome work. Thanks

    ReplyDelete

Subscribe to: Post Comments (Atom)