Loading images to a word document efficiently RRS feed

  • Question

  • I modified someone else's code to do something for my own needs.  My job requires me to put hundreds and hundreds of pictures into a word document, each having its own page and caption.  My code sucks though, and I know it.  I'm a novice AT BEST when it comes to VBA.  It works really well on small projects of 100-200 pictures, but anymore than ~300 and it just locks up and I can't wait for it that long.  Anyway, the code will open a dialog box to select a folder, and then anything that is an image is thrown into the word doc.  The file name becomes the caption using removeextension and removepath.

    Any help would be greatly appreciated!

    Option Explicit
    Sub InsertImage()
        Dim FolderPath, objFSO, Folder, ImagePath, image
        Dim ImageName As String
        Dim Pic As Object
        Const END_OF_STORY = 6
        Const MOVE_SELECTION = 0
        Application.ScreenUpdating = False
        FolderPath = Select_Folder_From_Prompt
        If InStr(FolderPath, "EMPTY") = 0 Then
            Set objFSO = CreateObject("Scripting.Filesystemobject")
            Set Folder = objFSO.GetFolder(FolderPath)
            For Each image In Folder.Files
                ImagePath = image.Path
                If CheckiImageExtension(ImagePath) = True Then
                    'Insert the images into the word document
                    ImageName = RemoveExtension(RemovePath(ImagePath))
                    With Application.Selection
                      .EndKey END_OF_STORY, MOVE_SELECTION
                      Set Pic = .InlineShapes.AddPicture(ImagePath)
                      If .PageSetup.Orientation = wdOrientLandscape Then
                        Pic.Width = Pic.Width * (440 / Pic.Height)
                        Pic.Height = 440
                        Pic.Width = Pic.Width * (620 / Pic.Height)
                        Pic.Height = 620
                      End If
                        .EndKey END_OF_STORY, MOVE_SELECTION
                        .InsertCaption Label:="Figure", TitleAutoText:="", Title:= _
           ": " & ImageName, Position:=wdCaptionPositionBelow, ExcludeLabel:=0
                    End With
                End If
        End If
        Application.ScreenUpdating = True
    End Sub

    'Function Prompt_For_Captions()
    ''    Dim message As String
    ''    Dim capbutton1 As String
    ''    Dim capbutton2 As String
    ''    message = "Would you like to enter captions yourself or use the file names?"
    ''    capbutton1 = "Enter Manually"
    ''    capbutton2 = "Automatically From Filename"
    ''    Private Sub UserForm_Initialize()
    ''        TextBox1.Text = message
    ''    End Sub
    'End Function

    Function Select_Folder_From_Prompt() As String
        Dim fd, bMultiSelect, CONST_MODEL_DIRECTORY
        Set fd = Application.FileDialog(msoFileDialogFolderPicker)
        With fd
            .Title = "Select a folder"
            .AllowMultiSelect = bMultiSelect
            .InitialFileName = CONST_MODEL_DIRECTORY
             'Use the Show method to display the File Picker dialog box and return the user's action.
             'The user pressed the action button.
            If .Show = -1 Then
                Select_Folder_From_Prompt = .SelectedItems(1) & "\"
                Select_Folder_From_Prompt = "EMPTY"
            End If
        End With
    End Function

    Function CheckiImageExtension(ImagePath)
        Dim varArray        ' An array contains iamge file extensions.
        Dim varEach         ' Each iamge file extension.
        Dim blnIsPptFile    ' Whether the file extension is image file extension.
        Dim objFSO, file, FileExtension
        Set objFSO = CreateObject("Scripting.Filesystemobject")
        Set file = objFSO.GetFile(ImagePath)
        FileExtension = file.Name
        blnIsPptFile = False
        If FileExtension <> "" Then
            varArray = Array(".emf", ".wmf", ".jpg", ".jpeg", ".jfif", ".png", ".jpe", ".bmp", ".dib", ".rle", ".gif", ".emz", ".wmz", ".pcz", ".tif", ".tiff", ".eps", ".pct", ".pict", ".wpg")
            For Each varEach In varArray
                If InStrRev(UCase(FileExtension), UCase(varEach)) <> 0 Then
                    blnIsPptFile = True
                    Exit For
                End If
        End If
        CheckiImageExtension = blnIsPptFile
        Set objFSO = Nothing
        Set file = Nothing
    End Function

    Public Function RemovePath(ByVal NameAndPath As String) As String
        Dim Offset As Integer, newoffset As Integer
        newoffset = 0
            Offset = newoffset
            newoffset = InStr(Offset + 1, NameAndPath, "\")
        Loop While newoffset
        RemovePath = Right$(NameAndPath, Len(NameAndPath) - Offset)
    End Function

    Public Function RemoveExtension(ByVal FileName As String) As String
        Dim intPosition As Integer
        FileName = RemovePath(FileName)
        If (FileName = "" Or Len(FileName) = 0) Then
            RemoveExtension = ""
            intPosition = InStrRev(FileName, ".")
            If (intPosition > 1) Then
                RemoveExtension = Left$(FileName, intPosition - 1)
                RemoveExtension = ""
            End If
        End If
    End Function

    Tuesday, August 27, 2013 6:06 PM

All replies

  • I had to do this for a client.  They had 100's of photos they needed needed in a Word doc and they needed to email the PDF so the doc needed to be less than 20Mb.  All their pics were taken with 4M pixel cameras and were way too large.  I figured out that 96 dots per inch printed fine for them.  They wanted the option of putting 2, 4 or 6 pics/page.  I determine what that translated to in horizontal and vertical pixels.  I use ImageMajick (free) to resize pic to right size.  Imagemajick has a COM interface so I call it from VBA.  You can also use Win32 commands.  This reduced the size of the file by 20X.  Without resizing I think the doc becomes unmanageable.

    • Edited by mogulman52 Wednesday, August 28, 2013 1:56 AM
    Wednesday, August 28, 2013 12:59 AM
  • I would be inclined to use mail merge for this task. Setup a worksheet with the image paths and the captions and use it to merge into a Word document - see

    Graham Mayor - Word MVP

    Wednesday, August 28, 2013 7:02 AM
  • I have also added the option to use an Excel list of images, their paths and captions to my Photo Gallery Template, which will create photo galleries in various layouts, including one per page.

    Graham Mayor - Word MVP

    Wednesday, August 28, 2013 12:18 PM