Не могу решить один вопрос.!!Хелп.....EXEL!!изображения !!!

[EducatedFool]

Возможно ли указать все расширения графики и как это сделать?

Возможно, но есть способ проще и эффективнее - пытаться вставить на лист изображения из ВСЕХ найденных файлов. В случае, если при загрузке изображения из файла возникает ошибка (если файл не является картинкой), просто пропускать такой файл.
Если надо - адаптирую код под такой вариант.

[elf80]

Буду благодарен за доработку!!!

[EducatedFool]

Теперь макрос собирает ВСЕ графические файлы в текущей папке, и во всех подпапках:




Вот весь код:

Option Compare Text
Public FileNames As Collection

Sub Main()
    On Error Resume Next
    ' оставьте одну из следующих двух строк:
    ПутьКПапкеСКартинками = "C:\Documents and Settings\Игорь\Рабочий стол\тест"    ' конкретная папка
    ПутьКПапкеСКартинками = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, "")    ' там же, где и этот файл

    Application.ScreenUpdating = False: msg = "": Application.DisplayAlerts = False
    Dim sh As Worksheet: Set sh = ActiveSheet
    Очистка    ' очистка всех ячеек листа от прежнего содержимого
    Set FileNames = New Collection: On Error Resume Next
    Call ReadFileNames(ПутьКПапкеСКартинками)    ' поиск подходящих файлов во всех подпапках

    Dim cell As Range, ra As Range: Application.ScreenUpdating = False

    For Each file In FileNames
        Set cell = Range("b" & Rows.Count).End(xlUp).Offset(1)
        If ВставитьКартинку(cell.Previous, file) Then cell = Dir(file)
    Next
    Application.ScreenUpdating = True
End Sub

Sub Очистка()
    Dim sha As Shape: Application.ScreenUpdating = False
    For Each sha In ActiveSheet.Shapes
        If sha.Type = msoPicture Then sha.Delete
    Next
    [2:1000].ClearContents
    ActiveSheet.UsedRange.EntireRow.AutoFit
End Sub

Function ВставитьКартинку(ByRef cell As Range, ByVal Pic As String) As Boolean
    ' если картинка вставлена успешно, возвращает TRUE
    On Error Resume Next: Err.Clear
    Dim ph As Picture: Set ph = cell.Parent.Pictures.Insert(Pic)
    ВставитьКартинку = Err.Number = 0
    ph.Top = cell.Top: ph.Left = cell.Left: k = ph.Width / ph.Height
    ph.Width = cell.Width: ph.Height = ph.Width / k
    cell.EntireRow.RowHeight = ph.Height
End Function

Function ReadFileNames(ByVal FolderPath As String)
    Set fso = CreateObject("scripting.filesystemobject")
    Set curfold = fso.GetFolder(FolderPath)

    If Not curfold Is Nothing Then
        For Each fil In curfold.Files
            FileNames.Add fil.Path
        Next
        For Each sfol In curfold.SubFolders
            ReadFileNames sfol.Path
        Next
        Set fil = Nothing: Set curfold = Nothing: Set fso = Nothing:
    End If
End Function

[elf80]

Большое СПАСИБО!!!