Вставьте картинку с оператором if на основе соотношения сторон (ширина / длина> 1 или <1)

Question

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

Sub INSERTPICTURES()
Dim shp As Shape
Dim ws As Worksheet
For Each ws In Worksheets
With ws
    Dim cella As Range

    'ActiveWorkbook.SaveAs (ThisWorkbook.Path & "\" & Range("L2") & "\2_handover\CONDITION_SURVEY_REPORT\SURVEY_REPORT_" & Range("L2") & ".xlsm")

    For Each cella In .Range("a1:i60").Cells

        If cella.Interior.ColorIndex = 48 Then

        Set shp = ws.Shapes.AddPicture(Filename:=cella, LinkToFile:=msoFalse, SaveWithDocument:=msoCTrue, Left:=cella.MergeArea.Left, Top:=cella.MergeArea.Top, Width:=cella.MergeArea.Width, Height:=cella.MergeArea.Height)
        'cella.UnMerge
        shp.Name = cella.Value

        'ActiveSheet.Hyperlinks.Add cella, cella.Value
        On Error Resume Next

        End If
    Next cella
End With
Next ws
End Sub

Можно ли построить оператор if, который будет проверять соотношение сторон исходного изображения (ширина / длина) )? И если он больше 1 или размер пикселя по ширине больше размера пикселя по длине, вставьте его с указанными выше параметрами (например, cella.MergeArea.theparameters), а если отношение меньше, чем 1 (таким образом, изображение имеет портретную ориентацию), я устанавливаю параметры top, left, width, length с фиксированными значениями?

Answer 1

Сначала вставьте изображение с его шириной и высотой по умолчанию, а затем проверьте его соотношение сторон и т. Д. c. Также вам необходимо исправить ошибки. Попробуйте следующее ...

EDIT : обратите внимание, что код был изменен так, что для каждой ячейки в A1: I60 сначала проверяется ошибка, а затем проверяется пробел ячейка, затем он проверяет colorindex, а затем проверяет, что путь и имя файла верны. Если это так, он вставляет изображение. В противном случае появляется сообщение о том, что файл не найден, а также путь и имя файла, которые он не может найти. После завершения тестирования вы можете удалить окно сообщения.

Sub INSERTPICTURES()
    Dim shp As Shape
    Dim ws As Worksheet
    For Each ws In Worksheets
        With ws
            Dim cella As Range
            'ActiveWorkbook.SaveAs (ThisWorkbook.Path & "\" & Range("L2") & "\2_handover\CONDITION_SURVEY_REPORT\SURVEY_REPORT_" & Range("L2") & ".xlsm")
            For Each cella In .Range("a1:i60").Cells
                If Not IsError(cella) Then
                    If Len(cella) > 0 Then
                        If cella.Interior.ColorIndex = 48 Then
                            If FileExists(cella.Value) Then
                                Set shp = ws.Shapes.AddPicture(Filename:=cella, LinkToFile:=msoFalse, SaveWithDocument:=msoCTrue, Left:=cella.MergeArea.Left, Top:=cella.MergeArea.Top, Width:=-1, Height:=-1) 'default width and height
                                With shp
                                    .Name = cella.Value
                                    If .Width > .Height Then
                                        .LockAspectRatio = msoFalse
                                        .Width = cella.MergeArea.Width
                                        .Height = cella.MergeArea.Height
                                    Else
                                        'set .LockAspectRatio to msoFalse
                                        'set width to fixed value
                                        'set height to fixed value
                                    End If
                                End With
                                'ActiveSheet.Hyperlinks.Add cella, cella.Value
                            Else
                                MsgBox "File not found:" & vbCrLf & vbCrLf & cella.Value, vbExclamation
                            End If
                        End If
                    End If
                End If
            Next cella
        End With
    Next ws
End Sub

Public Function FileExists(ByVal sFullname As String) As Boolean

    'returns True if file exists, otherwise it returns False
    'sFullname must contain both the path and filename (ie. c:\users\domenic\documents\sample.jpg)

    Dim fso As Object

    Set fso = CreateObject("Scripting.FileSystemObject")

    FileExists = fso.FileExists(sFullname)

    Set fso = Nothing

End Function

Надеюсь, это поможет!