Форум программистов
 

Восстановите пароль или Зарегистрируйтесь на форуме, о проблемах и с заказом рекламы пишите сюда - alarforum@yandex.ru, проверяйте папку спам!

Вернуться   Форум программистов > Microsoft Office и VBA программирование > Microsoft Office Word
Регистрация

Восстановить пароль
Повторная активизация e-mail

Купить рекламу на форуме - 42 тыс руб за месяц

Ответ
 
Опции темы Поиск в этой теме
Старый 24.02.2023, 09:09   #1
Niyetkhan
Пользователь
 
Регистрация: 27.10.2016
Сообщений: 26
По умолчанию Вставка нескольких рисунков в таблицу построчно

Здравствуйте!


Имеется множество рисунков в одной папке.
Стоит такая задача:
В Word надо создать таблицу и вставить все рисунки в ячейки одного столбца этой созданной таблицы построчно.

Нашел один код.
Но он после каждой строки с рисунков добавляет еще одну строку с номером рисунка и именем файла.

Можно ли изменить код так, чтобы

1. Не добавлялась эта строка с номером рисунка и именем файла
Нужно, чтобы вставлялись только рисунки, один за одним, и ничего больше.

2. И высота строк чтобы соответствовала размерам рисунков – установить авто высота строк.


С уважением,
Ниетхан
[Sub AddPics()
Application.ScreenUpdating = False
Dim oTbl As Table, i As Long, j As Long, StrTxt As String
'Select and insert the Pics
With Application.FileDialog(msoFileDialo gFilePicker)
.Title = "Select image files and click OK"
.Filters.Add "Images", "*.gif; *.jpg; *.jpeg; *.bmp; *.tif; *.png"
.FilterIndex = 2
If .Show = -1 Then
'Add a 2-row by 1-column table with 7cm column width to take the images
Set oTbl = Selection.Tables.Add(Selection.Rang e, 2, 1)
With oTbl
.AutoFitBehavior (wdAutoFitFixed)
.Columns.Width = CentimetersToPoints(7)
'Format the rows
Call FormatRows(oTbl, 1)
End With
CaptionLabels.Add Name:="Picture"
For i = 1 To .SelectedItems.Count
j = i * 2 - 1
'Add extra rows as needed
If j > oTbl.Rows.Count Then
oTbl.Rows.Add
oTbl.Rows.Add
Call FormatRows(oTbl, j)
End If
'Insert the Picture
ActiveDocument.InlineShapes.AddPict ure _
fileName:=.SelectedItems(i), LinkToFile:=False, _
SaveWithDocument:=True, Range:=oTbl.Rows(j).Cells(1).Range
'Get the Image name for the Caption
StrTxt = Split(.SelectedItems(i), "")(UBound(Split(.SelectedItems (i), "")))
StrTxt = ": " & Split(StrTxt, ".")(0)
'Insert the Caption on the row below the picture
With oTbl.Rows(j + 1).Cells(1).Range
.InsertBefore vbCr
.Characters.First.InsertCaption _
Label:="Picture", Title:=StrTxt, _
Position:=wdCaptionPositionBelow, ExcludeLabel:=False
.Characters.First = vbNullString
.Characters.Last.Previous = vbNullString
End With
Next
Else
End If
End With
Application.ScreenUpdating = True
End Sub
'
Sub FormatRows(oTbl As Table, x As Long)
With oTbl
With .Rows(x)
.Height = CentimetersToPoints(7)
.HeightRule = wdRowHeightExactly
.Range.style = "Обычный"
End With
With .Rows(x + 1)
.Height = CentimetersToPoints(0.75)
.HeightRule = wdRowHeightExactly
.Range.style = "Обычный"
End With
End With
End Sub
Niyetkhan вне форума Ответить с цитированием
Старый 24.02.2023, 09:50   #2
evg_m
Старожил
 
Регистрация: 20.04.2008
Сообщений: 5,527
По умолчанию

Цитата:
Можно ли изменить код так, чтобы
можно
Цитата:
1. Не добавлялась эта строка с номером рисунка и именем файла
на вставлять(Insert)
Цитата:
'Insert the Caption on the row below the picture
программа — запись алгоритма на языке понятном транслятору
evg_m вне форума Ответить с цитированием
Старый 24.02.2023, 10:00   #3
Niyetkhan
Пользователь
 
Регистрация: 27.10.2016
Сообщений: 26
По умолчанию

Спасибо за ответ

Я удалил эту строку.
Но все равно вставляется одна лишняя пустая строка после строки с рисунком.
Только исчезло отображение имени файла рисунка, больше ничего

Было удалено:
With oTbl.Rows(j + 1).Cells(1).Range
.InsertBefore vbCr
.Characters.First.InsertCaption _
Label:="Picture", Title:=StrTxt, _
Position:=wdCaptionPositionBelow, ExcludeLabel:=False
.Characters.First = vbNullString
.Characters.Last.Previous = vbNullString
End With
Niyetkhan вне форума Ответить с цитированием
Старый 25.02.2023, 06:45   #4
Niyetkhan
Пользователь
 
Регистрация: 27.10.2016
Сообщений: 26
По умолчанию

Код:
Sub AddPics()
    Application.ScreenUpdating = False
    Dim oTbl As Table, i As Long, j As Long, StrTxt As String
     'Select and insert the Pics
    With Application.FileDialog(msoFileDialogFilePicker)
        .Title = "Select image files and click OK"
        .Filters.Add "Images", "*.gif; *.jpg; *.jpeg; *.bmp; *.tif; *.png"
        .FilterIndex = 2
        If .Show = -1 Then
             'Add a 2-row by 1-column table with 7cm column width to take the images
            Set oTbl = Selection.Tables.Add(Selection.Range, 2, 1)
            With oTbl
                .AutoFitBehavior (wdAutoFitFixed)
                .Columns.Width = CentimetersToPoints(7)
                 'Format the rows
                Call FormatRows(oTbl, 1)
            End With
            CaptionLabels.Add Name:="Picture"
            For i = 1 To .SelectedItems.Count
                j = i * 1
                 'Add extra rows as needed
                If j > oTbl.Rows.Count Then
                    oTbl.Rows.Add
                    oTbl.Rows.Add
                    Call FormatRows(oTbl, j)
                End If
                 'Insert the Picture
                ActiveDocument.InlineShapes.AddPicture _
                fileName:=.SelectedItems(i), LinkToFile:=False, _
                SaveWithDocument:=True, Range:=oTbl.Rows(j).Cells(1).Range
                 'Get the Image name for the Caption
                StrTxt = Split(.SelectedItems(i), "")(UBound(Split(.SelectedItems(i), "")))
                StrTxt = ": " & Split(StrTxt, ".")(0)
                             Next
        Else
        End If
    End With
    Application.ScreenUpdating = True
End Sub
 '
Sub FormatRows(oTbl As Table, x As Long)
    With oTbl
        With .Rows(x)
            .Height = CentimetersToPoints(7)
            .HeightRule = wdRowHeightExactly
            .Range.style = "Обычный"
        End With
        End With
End Sub

Код подправил, работает.
Теперь не знаю, как установить автовысоту строк - чтобы высота строки была по размеру содержимого рисунка.

Последний раз редактировалось Niyetkhan; 25.02.2023 в 06:49.
Niyetkhan вне форума Ответить с цитированием
Старый 25.02.2023, 08:19   #5
Niyetkhan
Пользователь
 
Регистрация: 27.10.2016
Сообщений: 26
По умолчанию

И еще один вопрос:
Как сделать так чтобы рисунки, которые вставляются, были в оригинальном размере?
Niyetkhan вне форума Ответить с цитированием
Ответ


Купить рекламу на форуме - 42 тыс руб за месяц

Опции темы Поиск в этой теме
Поиск в этой теме:

Расширенный поиск


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
Поиск нескольких значений и вставка результатов zenner Microsoft Office Excel 19 12.09.2021 02:10
Вставка в Таблицу Maksim1979 Помощь студентам 3 30.03.2021 14:24
Вставка и редактирование рисунков в Word. VBA. RAN. Microsoft Office Word 6 20.06.2018 10:34
VBA вставка в одну ячейку из нескольких Tirendus Microsoft Office Excel 3 09.07.2009 19:57
Вставка нескольких песен и проигрывание по кнопке Forte HTML и CSS 2 26.06.2009 11:16