20170907wdVBA_ImportPicturesBaseOnExcel

Posted 2020-10-05 Excel VBA 小天地

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