VBA Excel自动调整图像大小边界 [英] VBA Excel automatic image resize & border

问题描述

我希望调整图像大小并与黑色线条(厚度1)接壤.

I would like to have my image properly resized and bordered with the black line, thickness 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

，一切都进行了调整，但是:

, everything was adjusted fine, but:

1. 仅对指定的形状ID(即图片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

最后我得到了错误:类型不匹配，调试器指出了这一点:

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://docs.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..."?

推荐答案

尝试以下代码.

阅读代码的注释并对其进行调整以适合您的需求

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

代码检查图片是否在目标广告范围内，然后调整其属性.

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

代码:

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

让我知道它是否有效

这篇关于VBA Excel自动调整图像大小边界的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！