|
Option Explicit
Sub test()
Dim ar, i&, j&, r&, wdApp As Word.Application, strFileName$, strPath$, strSaveName$, pic As Word.InlineShape
strPath = ThisWorkbook.Path & "\"
ar = [A1].CurrentRegion.Value
For i = 2 To UBound(ar)
strFileName = strPath & ar(i, 1)
If Dir(strFileName) <> "" Then
r = r + 1
For j = 1 To UBound(ar, 2)
ar(r, j) = ar(i, j)
Next j
ar(r, 1) = strFileName
End If
Next i
If r = 0 Then MsgBox "没找到图片文件": Exit Sub
ar = cutArray1(ar, 2, 0, r)
strFileName = strPath & "准考证模版.docx"
If Dir(strFileName) = "" Then MsgBox "模板文件不存在!": Exit Sub
Application.ScreenUpdating = False
On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
If Err <> 0 Then
Set wdApp = CreateObject("Word.Application")
'wdApp.Visible = True
End If
With wdApp.Documents.Add
.PageSetup.Orientation = wdOrientLandscape
strSaveName = strPath & "生成表"
For i = 1 To UBound(ar)
With wdApp.Documents.Open(strFileName)
For j = 1 To UBound(ar(i))
With .Tables(j)
.Range.Cells(3).Range.Text = ar(i)(j, 2)
.Range.Cells(10).Range.Text = ar(i)(j, 3)
Set pic = .Range.Cells(4).Range.InlineShapes.AddPicture(ar(i)(j, 1))
With pic
.LockAspectRatio = True
.Width = 85
End With
End With
Next j
.Range(0).Select
.Range(0).Copy
.Close False
End With
With wdApp.Selection
If i <> 1 Then .InsertBreak 7
.Paste
End With
Next i
.SaveAs2 strSaveName: .Close
End With
If Err <> 0 Then wdApp.Quit
Set wdApp = Nothing
Application.ScreenUpdating = True
Beep
End Sub
Function cutArray1(ByVal ar, ByVal iCutNum&, Optional _
ByVal iHeader& = 1, Optional ByVal iEndNum& = 0) As Variant()
Dim br(), cr(), i&, j&, iPosRow&, r&, k&
If iEndNum = 0 Or iEndNum > UBound(ar) Then iEndNum = UBound(ar)
For i = iHeader + 1 To iEndNum Step iCutNum
iPosRow = IIf((i + iCutNum - 1) > iEndNum, (iEndNum - iHeader) Mod iCutNum, iCutNum)
ReDim cr(1 To iPosRow + iHeader, 1 To UBound(ar, 2))
For j = iHeader + 1 To UBound(cr)
For k = 1 To UBound(cr, 2)
cr(j, k) = ar(i - 1 + j - iHeader, k)
Next k
Next j
For j = 1 To iHeader
For k = 1 To UBound(cr, 2)
cr(j, k) = ar(j, k)
Next k
Next j
r = r + 1
ReDim Preserve br(1 To r)
br(r) = cr
Next i
cutArray1 = br
End Function
|
|