Вставка полноразмерных картинок из HDD в ячейки

[Lama Under Cover]

Макрос с сайта http://ExcelVBA.ru

На данный момент работает исправно, за исключением случая, когда вставляется "глубокое фото" (т.е. когда длина меньше высоты) в ряду с прочими:

Option Compare Text
Public FileNames As Collection

Sub Main()
    On Error Resume Next
      
    ПутьКПапкеСКартинками = 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
        Debug.Print Dir(file)
        Set cell = Range("b" & Rows.Count).End(xlUp).Offset(1)
        ВставитьКартинку cell.Previous, file
        cell = Dir(file)
    Next
    Application.ScreenUpdating = True
End Sub

Sub ВставитьКартинку(ByRef cell As Range, ByVal Pic As String)
    On Error Resume Next
    Dim ph As Picture: Set ph = cell.Parent.Pictures.Insert(Pic)
    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 Sub

Для удаления картинок используется:

Sub УдалениеКартинок()
On Error Resume Next
ActiveSheet.Shapes.SelectAll
Selection.Delete
On Error GoTo 0
End Sub

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

Спасибо за Ваши ответы!

[EducatedFool]

Специально для устранения этих проблем я сделал расширенную версию этого макроса:
http://excelvba.ru/programmes/PastePictures
Там все вставляется корректно, и много опций по настройке размеров

[Lama Under Cover]

Сообщение от EducatedFool

Специально для устранения этих проблем я сделал расширенную версию этого макроса:
http://excelvba.ru/programmes/PastePictures
Там все вставляется корректно, и много опций по настройке размеров

Добрый вечер! Тестирую на данный момент несколько вариантов

1) вставка в примечания с http://www.planetaexcel.ru/techniques/9/128/;
2) указанный выше макрос;
3) Вашу надстройку;
4) нашел еще один Ваш макрос (код ниже), интересно:

что изменить нужно для того, чтобы уменьшить картинку при сохранении пропорций в данном коде

Private Sub Workbook_SheetSelectionChange(ByVal sh As Object, ByVal Target As Range)
    On Error Resume Next
    Dim cell As Range: Set cell = Target.EntireRow.Cells(4)
    If cell.Hyperlinks.Count > 0 Then
        PicPath = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, cell.Hyperlinks(1).Address)
        If Dir(PicPath) <> "" Then
            With F
                .Picture = LoadPicture(PicPath)
                .Width = F.Picture.Width / 143: .Height = F.Picture.Height / 143
                .Top = Application.Top + 19 'отступы от окна
                .Left = Application.Left + 19 'отступы от окна
                .Caption = cell.Previous.Previous.Previous: .Show
            End With
        End If
    Else
        F.Hide
    End If
End Sub

[Lama Under Cover]

Дело в том, что качественные фотографии, например 5000 на 3000 пикселей сразу открываются в масштабе 100%, по этой причине моего монитора 1920 1080 не хватает на подобные превьюшки!

Как лучше сделать то же самое, но уже с двумя столбцами для каждого имени, т.е. вместо текущего одного изображения для наименования будут отображаться два?

Сам для этого заменил

Target.EntireRow.Cells(4)

на

Target.Cells

, все работает, однако имена коротких файлов открываются по ссылке при выделении ячейки, чего не происходит с длинными именами =/


Файл в приложении! Для корректной работы обязательно нужно разархивировать файлы после скачивания

[Lama Under Cover]

Разобрался! Всему виной то, что названия файлов у меня содержали лишь цифры, поэтому приходилось ждать при наведении несколько секунд.

Надеюсь на чью-либо помощь в разрешении основной задачи - уменьшить картинку при сохранении пропорций..

[Step_UA]

Сообщение от Lama Under Cover

...уменьшить картинку при сохранении пропорций..

Если под уменьшением подразумевается ее "полное" отображение в форме, то установите для свойства формы PictureSizeMode значение fmPicrureSizeModeZoom

[Lama Under Cover]

Сообщение от Step_UA

Если под уменьшением подразумевается ее "полное" отображение в форме, то установите для свойства формы PictureSizeMode значение fmPicrureSizeModeZoom

Спасибо! Спасли идею =]

Лучшее решение для предпросмотра картинок, на мой взгляд, из всех рассмотренных мною, именно это!

Все работает! И, что самое главное, быстро работает!