Вставка картинок в документ.

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

    1 
    2 
    3 
    4 
    5 
    6 
    7 
    8 
    9 
   10 
   11 
   12 
   13 
   14 
   15 
Sub ДобавлениеКартинок()
  Dim oPicture As InlineShape
  Dim sFileName As String, sFileNameShort As String
'***********************************************************************************
  With Application.FileDialog(msoFileDialogOpen)
    .AllowMultiSelect = False
    .ButtonName = "Вставить": .InitialView = msoFileDialogViewPreview: .Title = "Вставить картинку с названием"
    .Filters.Clear: .Filters.Add "Изображения", "*.jpg;*.jpeg;*.gif;*.png;*.bmp": .Filters.Add "Все файлы", "*.*"
    If .Show Then sFileName = .SelectedItems(1) Else Exit Sub
  End With
  sFileNameShort = CreateObject("Scripting.FileSystemObject").GetFile(sFileName).ShortName
  sFileNameShort = Mid(sFileNameShort, 1, InStrRev(sFileNameShort, ".") - 1)
  Set oPicture = ActiveDocument.InlineShapes.AddPicture(sFileName, False, True, Selection.Range)
  oPicture.Select: Selection.InsertCaption "Рисунок", " " & sFileNameShort
End Sub

Как работает? Пользователю дают выбрать файл. Затем этот файл вставляется как картинка в документ и к картинке добавляется автоназвание. Вот и все. Просто и эффективно.

Кризис, однако…

В связи с кризисом остается мало времени на обновление данных для блога. Хотя есть чем поделиться. Например, методы работы с классами и коллекциями. Очень полезная штука. А также тонкости работы с графическими объектами в Word (как оказалось они требуют очень бережного отношения).
Сегодня кратко

Копировать код без номеров строк

1 With Application.FileDialog(msoFileDialogFolderPicker)
2 .AllowMultiSelect = False
3 .Title = "Выберите папку с фотографиями"
4 If .Show <> 0 Then
5 sPath = .SelectedItems(1) & "\"
6 Else: MsgBox "Вы не выбрали папку. Запустите макрос снова.": Exit Sub:
7 End If
8 End With

Копировать код без номеров строк

1 With Application.FileDialog(msoFileDialogFilePicker)
2 .AllowMultiSelect = False
3 If .Show <> 0 Then
4 dfile = .SelectedItems(1)
5 Workbooks.Open dfile
6 Else
7 MsgBox "Вы нажали «Отмена»"
8 End If
9 End With