VBA Excel автоматизированный c изменение размера изображения и границы

Question

Я бы хотел, чтобы мое изображение было правильно изменено и окаймлено черной линией, толщиной 1.

Моя ситуация выглядит следующим образом:

и когда я использовал этот код:

 Sub ResizeCivilsA()
 SizeToRange Sheets("Civils 1").Pictures("Picture 29"), Range("B3:L46")
 End Sub

 Function SizeToRange(s, Target As Range)
 s.Left = Target.Left + 10
 s.Top = Target.Top - 5
 s.Width = Target.Width
 s.Height = Target.Height
 End Function

, все было настроено нормально, но:

1. Это было сделано только для указанного идентификатора формы, который это "Изображение 29"
2. Это было без границ

Итак, я попытался:

Sub ResizeCivilsA()
     Dim shp As Shape
     For Each shp In ThisWorkbook.Worksheets
        If shp.Name Like "*Picture*" Then
        SizeToRange shp, Range("B3:L46")
     End If
    Next

и, наконец, я получаю ошибку: Тип несоответствие , с отладчиком, указывающим линию:

For Each shp In ThisWorkbook.Worksheets

Что касается границы вокруг изображения, я нашел общее решение здесь:

https://docs.microsoft.com/en-us/office/vba/api/Excel.Range.BorderAround

Однако после того, как прибор вошел в мою работу:

    Worksheets("Civils 1").Shape("Picture 29").BorderAround _ 
    ColorIndex:=3, Weight:=xlThick

этого было недостаточно, так как мне пришлось удалить _ и потом ничего не получил.

Есть ли какой-то способ иметь возможность мгновенного изменения размера изображения и создания рамки вокруг него для ЛЮБОГО прикрепленного изображения, которое по умолчанию называется «Изображение ...»?

Answer 1

Первоначальное чтение выглядит так, как будто ваш For Each ищет Shape объектов, но вы предоставляете ему коллекцию Sheet объектов.

 For Each sht In ThisWorkbook.Worksheets
     For Each shp In sht.Shapes
         If shp.Name Like "*Picture*" Then
             Set r1 = shp.TopLeftCell
             Set r2 = r1.Offset(10, 43)
             SizeToRange shp, Range(r1.Address & ":" & r2.Address)
         End If
     Next shp
 Next sht

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

РЕДАКТИРОВАТЬ: Обновлено с относительным адресом.

Answer 2

Попробуйте этот код.

Прочитайте комментарии кода и настройте его в соответствии с вашими потребностями

РЕДАКТИРОВАТЬ: код проверяет, находится ли изображение в пределах целевого диапазона объявления, а затем корректирует его свойства.

Код:

Option Explicit

Public Sub ResizeAllShapesInSheet()

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

    ' Define the sheet that has the pictures
    Set targetSheet = ThisWorkbook.Worksheets("Civils 1")
    ' Define the range the images is going to fit
    Set targetRange = targetSheet.Range("B3:L46")

    ' 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
        End If

    Next targetShape

End Sub

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

    If Not (targetShape.Left >= Target.Left And _
        targetShape.Top >= Target.Top And _
        targetShape.Left + targetShape.Width <= Target.Left + Target.Width And _
        targetShape.Top + targetShape.Height <= Target.Top + Target.Height) Then Exit Sub

        ' Adjust picture properties
        With targetShape
            ' Check if next line is required...
            .LockAspectRatio = msoFalse
            .Left = Target.Left + 10
            .Top = Target.Top - 5
            .Width = Target.Width
            .Height = Target.Height
        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 = 6
        End With

End Sub

Дайте мне знать, если это работает