VBA macro in Excel to insert image in Word

[nemoy]

I'm working on a macro that includes a bunch of links to image files. I want to be able to select a given row in the document and have it insert that image into a word document. I have it working to an extent, but I can't get the images to be placed at end of document like I want.

With my current code I run one macro to create the document with a heading that includes the title of the quiz and a spot for the student's name.

Then I select the row for first image and run a second macro. The image file is inserted, but it is at the top of the document pushing the text down. When I continue to add pictures they are all added at the top pushing everything else down.

How can I fix this so that the image is inserted at the bottom?

Dim wrdApp
Dim wrdDoc


Sub CreateSheet()


    Set wrdApp = CreateObject("Word.Application")
    wrdApp.Visible = True
    Set wrdDoc = wrdApp.documents.Add ' create a new document


    With wrdDoc
        '.Selection.Style = .ActiveDocument.Styles("Title")
        .Content.InsertAfter Text:=InputBox("What is the name of document?", "Name", "MCQ Practice")
        .Content.InsertParagraphAfter
        .Content.ParagraphFormat.Alignment = wdAlignParagraphRight
        .Content.InsertAfter Text:="Name ______________"
    End With
    
    
End Sub






Sub InsertQuestion()


    wrdApp.Visible = True

    ' filename and directory stored in column L 
    file = Range("a1").Offset(ActiveCell.Row - 1, 11)


    With wrdDoc
        .Content.InlineShapes.AddPicture Filename:=file, LinkToFile:=False, SaveWithDocument:=True
        .Content.InsertParagraphAfter
    End With
    
End Sub

 

[NdNoviceHlp]

You could try adding this code before the input box. HTH. Dave

.Content.InsertAfter Text:= CHR(13)

 

[nemoy]

Nope, that just puts an extra empty line between the text and the images, but the images are still at the top.

This is what I get (notice the numbers in reverse order and the heading at the bottom):

Here is what I want:

 

[NdNoviceHlp]

After a more thorough reading of your request, I think you're missing abit of stuff. The following code will create and save your document. You have not posted the second sub to which you refer. However, there is no real need for a second sub. If you just want to add image files to the document you can just code for that. If you want to have the document open, and then insert image files after the selection point, that is different. Maybe add a bit more info including the relevant 2nd sub. Dave

Sub CreateSheet()
Dim WrdApp As Object, WrdDoc As Object
Set WrdApp = CreateObject("Word.Application")
'WrdApp.Visible = True
Set WrdDoc = WrdApp.documents.Add ' create a new document
With WrdDoc
.Content.InsertAfter Text:=InputBox("What is the name of document?", "Name", "MCQ Practice")
.Content.InsertParagraphAfter
' use numeric to avoid need for Word reference
.Content.ParagraphFormat.Alignment = 0 'wdAlignParagraphLeft
.Content.InsertAfter Text:="Name ______________"
End With
'close and save existing doc
WrdApp.activedocument.SaveAs ("C:\test\test.doc") 'change path to suit
Set WrdDoc = Nothing
WrdApp.Quit
Set WrdApp = Nothing
End Sub

 

[nemoy]

Thanks again, here is the second sub:

Sub InsertQuestion()
    wrdApp.Visible = True
 
   ' filename and directory stored in column L
     file = Range("a1").Offset(ActiveCell.Row - 1, 11)
    With wrdDoc
        .Content.InlineShapes.AddPicture Filename:=file, LinkToFile:=False, SaveWithDocument:=True
        .Content.InsertParagraphAfter
    End With
End Sub

Basically the first Sub opens a word document and gives it a heading. The second Sub inserts an image into the already opened document, preferably at the END of the document as opposed to how it currently works placing the image at the beginning of the document. The reason for the second sub is that I will be inserting multiple images from many different rows in the document. I'd rather not have to select or mark all of the images before creating the document.

 

[NdNoviceHlp]

Untested but seems like it should work. Dave

Sub CreateSheet()
Dim WrdApp As Object, WrdDoc As Object
Dim LastRow As Integer, Cnt As Integer, FileNm As String
Set WrdApp = CreateObject("Word.Application")
'WrdApp.Visible = True
With Sheets("Sheet1")
    LastRow = .Range("FW" & .Rows.Count).End(xlUp).Row
End With
Set WrdDoc = WrdApp.documents.Add ' create a new document
With WrdDoc
.Content.InsertAfter Text:=InputBox("What is the name of document?", "Name", "MCQ Practice")
.Content.InsertParagraphAfter
.Content.InsertAfter Text:="Name ______________"
For Cnt = 1 To LastRow
' filename and directory stored in column L (Rows 1 to last)
FileNm = Sheets("Sheet1").Range("L" & Cnt)
.TypeParagraph
.Content.InlineShapes.AddPicture Filename:=FileNm, LinkToFile:=False, SaveWithDocument:=True
Next Cnt
' use numeric to avoid need for Word reference
.Content.ParagraphFormat.Alignment = 0 'wdAlignParagraphLeft
End With
'close and save existing doc
WrdApp.activedocument.SaveAs ("C:\test\test.doc") 'change path to suit
Set WrdDoc = Nothing
WrdApp.Quit
Set WrdApp = Nothing
End Sub

 

[nemoy]

I appreciate your help again, tried running it this way and still get the images placed into the document in reverse order and on top of the text.

There must be a way to add inline shapes at the end of the document rather than at the beginning!

 

[NdNoviceHlp]

I should have tested the last code... apologies. This works. Dave

Sub CreateSheet()
Dim WrdApp As Object, WrdDoc As Object
Dim LastRow As Integer, Cnt As Integer, FileNm As String
Dim FS As Object, ObjSelection As Object
On Error GoTo ErFix
Set WrdApp = CreateObject("Word.Application")
'WrdApp.Visible = True
With Sheets("Sheet1")
    LastRow = .Range("L" & .Rows.Count).End(xlUp).Row
End With
Set WrdDoc = WrdApp.documents.Add ' create a new document
Set ObjSelection = WrdApp.Selection
ObjSelection.typetext InputBox("What is the name of document?", "Name", "MCQ Practice")
ObjSelection.typeparagraph
ObjSelection.typetext "Name ______________"
Set FS = CreateObject("Scripting.FileSystemObject")
For Cnt = 1 To LastRow
' filename and directory stored in column L (Rows 1 to last)
FileNm = Sheets("Sheet1").Range("L" & Cnt)
If FS.fileexists(FileNm) Then
ObjSelection.typeparagraph
ObjSelection.InlineShapes.AddPicture Filename:=FileNm
Else
MsgBox "No file: " & FileNm
End If
Next Cnt
With WrdDoc
' use numeric to avoid need for Word reference
.Content.ParagraphFormat.Alignment = 0 'wdAlignParagraphLeft
End With
'close and save existing doc
WrdApp.activedocument.SaveAs ("C:\test\test.doc") 'change path to suit
Set FS = Nothing
Set ObjSelection = Nothing
Set WrdDoc = Nothing
WrdApp.Quit
Set WrdApp = Nothing
Exit Sub
ErFix:
On Error GoTo 0
MsgBox "Error"
Set FS = Nothing
Set ObjSelection = Nothing
Set WrdDoc = Nothing
WrdApp.Quit
Set WrdApp = Nothing
End Sub

 

[nemoy]

You rock, thanks!

 

[NdNoviceHlp]

You are Welcome. Thanks for posting your outcome. Dave