Excel创建word并导入图片

Excel创建word并导入图片

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:\Users\fish.lol\Desktop\Data Collect\insert.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

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