Public Sub ImportPicturesBaseOnExcel()
Dim shp As Object
Dim xlApp As Object
Dim Wb As Object
Dim Rng As Object
Dim FolderPath As String
Dim ImgFolder As String
Dim ExcelPath As String
Dim FilePath As String
Const ExcelFile As String = "身份证号.xls"
FolderPath = ThisDocument.Path & "\"
ExcelPath = FolderPath & ExcelFile
ImgFolder = FolderPath & "照片\"
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If xlApp Is Nothing Then
Set xlApp = CreateObject("Excel.Application")
End If
On Error GoTo 0
Set Wb = xlApp.workbooks.Open(ExcelPath)
EndRow = Wb.worksheets(1).Range("A65536").End(3).Row
Set Rng = Wb.worksheets(1).Range("A2:A" & EndRow)
arr = Rng.Value
Wb.Close
xlApp.Quit
If ThisDocument.InlineShapes.Count > 0 Then
For Each shp In ThisDocument.InlineShapes
shp.Delete
Next shp
End If
If ThisDocument.Shapes.Count > 0 Then
For Each shp In ThisDocument.Shapes
shp.Delete
Next shp
End If
Selection.WholeStory
Selection.Delete
Selection.HomeKey wdStory
Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
For i = LBound(arr) To UBound(arr)
FilePath = ImgFolder & "*" & arr(i, 1) & "*.jpg"
Debug.Print FilePath
FileName = Dir(FilePath)
If FileName <> "" Then
FilePath = ImgFolder & FileName
n = n + 1
For j = 1 To 2
Set shp = ThisDocument.InlineShapes.AddPicture(FileName:=FilePath, _
LinkToFile:=False, SaveWithDocument:=True)
Selection.Collapse wdCollapseEnd
Next j
If n Mod 2 = 0 And n Mod 8 <> 0 Then
Selection.EndKey wdStory
Selection.TypeParagraph
End If
If n Mod 8 = 0 Then
Selection.EndKey wdStory
Selection.InsertBreak Type:=wdPageBreak
End If
End If
Next i
Set shp = Nothing
End Sub
