Сделал!
Как по мне это не очень красиво, но пока другого решения не нашел.
Буду благодарен за дельные мысли.
Мне не нравится то, что приходится выгружать InlineShapes в файлы а потом их подымать в таблицу.
Хотел сделать Cut/Paste, но не получилось
итак, нужны 2 процедурки
1. сгребает все InlineShapes в файлы в темповый фолдер
2. подымает все фотки из темпового фолдера и вставляет в таблицу
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
Function WriteInlineShapesToFile(Optional IsRemoveImgFromDoc As Boolean = True) As Variant
Dim arrPath() As String
Dim docCurrent As Document
Dim shapeCurrent As InlineShape
Dim RC As Integer
Dim vData() As Byte
Dim i As Long
Dim lWritePos As Long
Dim strOutFileName As String
Dim tempFolder As String
tempFolder = Environ("Temp") & "\"
Set docCurrent = ActiveDocument
i = 1
For Each shapeCurrent In docCurrent.InlineShapes
strOutFileName = tempFolder & "img" & CStr(i) & ".emf"
Open strOutFileName For Binary Access Write As #1
ReDim Preserve arrPath(i - 1)
arrPath(i - 1) = strOutFileName
i = i + 1
vData = shapeCurrent.Range.EnhMetaFileBits
lWritePos = 1
Put #1, lWritePos, vData
Close #1
If (IsRemoveImgFromDoc) Then
shapeCurrent.Delete
End If
Next shapeCurrent
'RC = MsgBox("Job complete.", vbOKOnly, "Job Status")
WriteInlineShapesToFile = arrPath()
End Function
основной макрос и запуск (параметр указывает сколько должно быть колонок) в таблице
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
Sub ArrangeInlineShapes(Optional ByVal cntCol As Integer = 2)
Dim curInShp As InlineShape
Dim curShp As Shape
Dim Table1 As Table
Dim curPage As Long, curTableIndex As Long
Dim iRow As Long, iCol As Long
Dim iteration As Long
Dim curTableRange As Range, rgCell As Range
Dim rgBuf As Range
Dim maxCountImg As Long
Dim arrImgPaths() As String
If (ActiveDocument.InlineShapes.Count > 0) Then
' select 1st InlineShapes in Document
Set curInShp = ActiveDocument.InlineShapes(1)
'curInShp.Range.Select
' insert Paragraf after 1st 1st InlineShapes
Set curTableRange = curInShp.Range
With curTableRange
.Collapse (WdCollapseDirection.wdCollapseEnd)
.Move WdUnits.wdCharacter, 1
.Select
.InsertParagraph
'.InsertBreak (WdBreakType.wdPageBreak)
End With
' detect PageNumber where 1st InlineShapes in Document
'curPage = curTableRange.Information(wdActiveEndAdjustedPageNumber)
arrImgPaths = WriteInlineShapesToFile(True)
maxCountImg = UBound(arrImgPaths)
Set Table1 = ThisDocument.Tables.Add(curTableRange, Round((maxCountImg + 1) / cntCol, 0), cntCol)
If (maxCountImg > 0) Then
iRow = 1: iCol = 1: iteration = 1
For i = 0 To maxCountImg
Set rgCell = Table1.Cell(iRow, iCol).Range
ActiveDocument.InlineShapes.AddPicture arrImgPaths(i), Range:=rgCell
iteration = iteration + 1
iCol = iCol + 1
If (iCol > cntCol) Then
iCol = 1
iRow = iRow + 1
End If
On Error Resume Next
Kill arrImgPaths(i)
Next i
End If
End If
End Sub
Sub Start()
ArrangeInlineShapes (3)
End Sub
не скажу что оптимально и быстро, но работает.
конструктивная критика приветствуется
