Установите все изображения по горизонтали

Question

Добрый день,

У меня проблема.

Используя следующую функцию:

 Private Sub SizeToRange(ByVal targetShape As Shape, ByVal Target As Range)

    ' Adjust picture properties
    With targetShape
        ' Check if next line is required...
        .LockAspectRatio = msoFalse
        .Left = Target.Left + 15
        .Top = Target.Top - 4
        .Width = Target.Width - 30
        .Height = Target.Height
        .ZOrder msoSendToBack

        '.IncrementRotation Deg
    End With

    ' Adjust picture border properties
    With targetShape.Line
        .Visible = msoTrue
        .ForeColor.RGB = RGB(0, 0, 0)
        .ForeColor.TintAndShade = 0
        .ForeColor.Brightness = 0
        .Transparency = 0
        .Visible = msoTrue
        .Weight = 1
    End With

End Sub

и код:

 Public Sub ResizeChambers()

Dim targetSheet As Worksheet
Dim targetRange As Range
Dim targetShape As Shape


' Define the sheet that has the pictures
Set targetSheet = ThisWorkbook.ActiveSheet

' Define the range the images is going to fit
Set targetRange = targetSheet.Range("E3:I16")

' Loop through each Shape in Sheet
For Each targetShape In targetSheet.Shapes

    ' Check "picture" word in name
    If targetShape.Name Like "*Picture*" Then
        ' Call the resize function
        SizeToRange targetShape, targetRange
        targetShape.Flip msoFlipHorizontal
    End If

Next targetShape

End Sub

Я пытаюсь установить все свои изображения по горизонтали.

Как видите, я использовал оба варианта: 1. targetShape.Flip msoFlipHorizontal для кода 2. .IncrementRotation Deg для функции

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

Как я могу сделать их все в горизонтальном выравнивании?

Answer 1

Вы можете выполнить sh это по-разному, используя Shape Range Collection Object, и либо использовать Shepes.SelectAll, либо выбрать каждый тип объекта формы без использования аргумента Replace, либо выбрать конкретный c Range. При необходимости измените тип формы и диапазон. Если у вас есть вопросы, задавайте их.

Пример 1: Использовать объект коллекции Shape Range

Dim shprng As ShapeRange

ActiveSheet.Shapes.SelectAll
Set shprng = Selection.ShapeRange

shprng.Align 3, 0 '3 is the enumeration for msoPicture, and 0 is the enumeration for msoFalse

Пример 2: Выберите тип формы

Dim shp As Shape
For Each shp In ActiveSheet.Shapes
    If shp.Type = 13 Then shp.Select False '13 is the enumeration for msoPicture
Next shp

With Selection.ShapeRange
    .Align 3, 0 '3 is the enumeration for msoALignTops, and 0 is the enumeration for msoFalse
End With

Пример 3: Использовать спецификацию c Диапазон

Dim shp As Shape, rng As Range
Set rng = ActiveSheet.Range("D4:O20")

For Each shp In ActiveSheet.Shapes
    If Not Intersect(Range(shp.TopLeftCell, shp.BottomRightCell), rng) Is Nothing And shp.Type = 13 Then shp.Select False '13 is the enumeration for msoPicture
Next shp

With Selection.ShapeRange
    .Align 3, 0 '3 is the enumeration for msoALignTops, and 0 is the enumeration for msoFalse
End With