|
|
Option Explicit
Option Compare Text
Sub TEST6()
Dim ar(), br(), i&, j&, r&, k&, m&, fso As Object, n$, dWeight As Double
Dim strPath$, strPath1, strPath2$, ff, f, picName, iRowCount&, pic As Picture
n = InputBox("请选择随机行数", Title:="提示", Default:=2)
If Val(n) = 0 Then Exit Sub
strPath = ThisDocument.Path & "\产品照片\"
If Dir(strPath, vbDirectory) = "" Then Exit Sub
Application.ScreenUpdating = False
Set fso = CreateObject("Scripting.FileSystemObject")
For Each ff In fso.GetFolder(strPath).SubFolders
r = r + 1
iRowCount = iRowCount + 1
ReDim Preserve ar(1 To 2, 1 To r)
ar(1, r) = ff.Name
Set ar(2, r) = CreateObject("Scripting.Dictionary")
strPath1 = strPath & ff.Name & "\"
For Each f In fso.GetFolder(strPath1).SubFolders
iRowCount = iRowCount + 1
Set ar(2, r)(f.Name) = CreateObject("Scripting.Dictionary")
strPath2 = strPath1 & f.Name & "\"
For Each picName In fso.GetFolder(strPath2).Files
If picName.Name Like "*.jpg" Then
ar(2, r)(f.Name)(picName.Name) = picName.Path
End If
ReDim br(1 To 2, 1 To ar(2, r)(f.Name).Count)
For j = 1 To UBound(br, 2)
br(1, j) = ar(2, r)(f.Name).Items()(j - 1)
br(2, j) = Split(ar(2, r)(f.Name).Keys()(j - 1), ".jpg")(0)
Next j
Next picName
br = transArrToRow(br, CLng(n))
ar(2, r)(f.Name) = br
iRowCount = iRowCount + UBound(br)
Next f
Next ff
With ActiveDocument
With .PageSetup
dWeight = (.PageWidth - .LeftMargin - .RightMargin) / n
End With
.Content.Delete
With .Tables.Add(Range:=.Range(0), NumRows:=iRowCount, NumColumns:=n, DefaultTableBehavior:=wdWord9TableBehavior)
r = 0
For j = 1 To UBound(ar, 2)
r = r + 1
With .Cell(r, 1).Range
.Text = ar(1, j)
.Font.Bold = True
.Font.Size = 14
End With
.Rows(r).Cells.Merge
For k = 0 To ar(2, j).Count - 1
r = r + 1
With .Cell(r, 1).Range
.Text = ar(2, j).Keys()(k)
.Font.Bold = True
.Font.Size = 12
End With
.Rows(r).Cells.Merge
br = ar(2, j).Items()(k)
For i = 1 To UBound(br)
r = r + 1
For m = 1 To UBound(br, 2)
If Len(br(i, m)) Then
If i Mod 2 = 1 Then
With .Cell(r, m).Range
With .InlineShapes.AddPicture(br(i, m), , True)
.LockAspectRatio = True
.Width = dWeight
End With
End With
Else
.Cell(r, m).Range.Text = br(i, m)
End If
End If
Next m
Next i
Next k
Next j
End With
End With
Application.ScreenUpdating = True
Beep
End Sub
Function transArrToRow(ar, iCutNum&, Optional iLeftCol& = 1 _
, Optional iRightCol& = 0) As Variant()
Dim br(), n&, i&, j&, k&, iPosRow&, iPosCol&, iEnd&
If iRightCol = 0 Then iRightCol = UBound(ar, 2)
n = -(Int(-(iRightCol - iLeftCol + 1) / iCutNum))
ReDim br(1 To UBound(ar) * n, 1 To iCutNum)
For i = 1 To n
iPosRow = (i - 1) * UBound(ar)
iPosCol = (i - 1) * iCutNum + iLeftCol
iEnd = IIf(iPosCol + iCutNum - 1 > iRightCol, _
(iRightCol - iLeftCol + 1) Mod iCutNum, iCutNum)
For j = 1 To UBound(ar)
For k = 1 To iEnd
br(iPosRow + j, k) = ar(j, iPosCol - 1 + k)
Next k
Next j
Next i
transArrToRow = br
End Function
|
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2024-4-14 11:03
楼主
