CODEWITHSUNDEEP
excelvba
Geographos
Geographos

Reputation: 1496

VBA Excel automatic image resize & border

I would like to have my image properly resized and bordered with the black line, thickness 1.

My situation looks like this:

enter image description here

and when I used this code:

 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

, everything was adjusted fine, but:

  1. It have been done only for the specified shape id, which is "Picture 29"
  2. It was without the borders

So I tried then:

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

and finally I am getting error: Type mismatch, with debugger pointing the line:

For Each shp In ThisWorkbook.Worksheets

Regarding the border around the image I found the common solution here:

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

However after appliance into my work:

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

it wasn't enough since I had to remove the _ and got nothing afterward.

Is there some way to have the possibility for instant resizing the image and making the border around it for ANY attached image, which as default is called "Picture..."?

Upvotes: 0

Views: 1455

Answers (2)

Ricardo Diaz
Ricardo Diaz

Reputation: 5696

Try this code.

Read code's comments and adjust it to fit your needs

EDIT: The code checks if picture is within target range ad then adjusts its properties.

Code:

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

Let me know if it works

Upvotes: 1

Eliot
Eliot

Reputation: 623

Initial read looks like your For Each is looking for Shape objects, but you are giving it a collection of Sheet objects.

 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

Hope that helps!

EDIT: Updated with relative address.

Upvotes: 1

Related Questions