主页 / coding / 问题 / 79565473
Accepted
Danny Coleiro
Asked: 2025-04-10 07:14:55 +0800 CST

在 Excel 应用程序中为矩形的边框和图像之间留出一些边距

  • 772

1）请在Excel应用程序中运行以下代码。

    Sub Macro1()
    
    'Delete all shapes if exists
    For i = ActiveSheet.Shapes.Count To 1 Step -1
        ActiveSheet.Shapes(i).Delete
    Next i
    
    'Add a Rectangle
    With ActiveSheet.Shapes.AddShape(Type:=msoShapeRectangle, Left:=20, Top:=20, Width:=200, Height:=120)
        .Name = "myRectangle"
    End With
    
    'Make some formatting to the myRectangle
    With ActiveSheet.Shapes("myRectangle")
       .Line.Visible = msoTrue
       .Line.ForeColor.RGB = vbBlue
       .Line.Weight = 5
       .Fill.UserPicture "https://upload.wikimedia.org/wikipedia/en/b/ba/Flag_of_Germany.svg"
    End With
    
    End Sub

2)请检查您的Excel 工作表中是否有以下矩形。

图片1

3)我正在寻找一个可以给我以下图片的宏。

正如您所理解的，我想在边界和旗帜之间留出一些空白。

图2

excel

2 个回答

  1. Best Answer

    请尝试.PictureFormat.Crop获取您的预期输出。

    Microsoft 文档：

    PictureFormat.Crop 属性（Word）PictureFormat.Crop 属性（Word）

    Sub Macro1()
    Dim i
    'Delete all shapes if exists
    For i = ActiveSheet.Shapes.Count To 1 Step -1
        ActiveSheet.Shapes(i).Delete
    Next i
    
    'Add a Rectangle
    With ActiveSheet.Shapes.AddShape(Type:=msoShapeRectangle, Left:=20, Top:=20, Width:=200, Height:=120)
        .Name = "myRectangle"
    End With
    
    'Make some formatting to the myRectangle
    With ActiveSheet.Shapes("myRectangle")
        .Line.Visible = msoTrue
        .Line.ForeColor.RGB = vbBlue
        .Line.Weight = 5
        .Fill.UserPicture "https://upload.wikimedia.org/wikipedia/en/b/ba/Flag_of_Germany.svg"
        
        With .PictureFormat.Crop
            Dim iW: iW = .PictureWidth
            Dim iH: iH = .PictureHeight
            Const OFFSET_PCT = 0.05  ' Modify as needed
            .PictureWidth = iW * (1 - 2 * OFFSET_PCT)
            .PictureHeight = iH * (1 - 2 * OFFSET_PCT * iW / iH)
        End With
    End With
    
End Sub

    在此处输入图片描述

    • 2

  2. 有很多方法可以尝试，也许最简单的方法是在第一个矩形的中间添加另一个较小的矩形：

    Sub Macro1()
    Dim i As Integer
    Dim smallLeft As Double
    Dim smallTop As Double
    Dim smallWidth As Double
    Dim smallHeight As Double
    
    'Delete all shapes if exists
    For i = ActiveSheet.Shapes.Count To 1 Step -1
        ActiveSheet.Shapes(i).Delete
    Next i
    
    'Add a big blue Rectangle
    With ActiveSheet.Shapes.AddShape(Type:=msoShapeRectangle, Left:=20, Top:=20, Width:=200, Height:=120)
        .Name = "myRectangle"
        .Line.Visible = msoTrue
        .Line.ForeColor.RGB = vbBlue
        .Line.Weight = 5
        .Fill.ForeColor.RGB = vbWhite
    End With
    
    'Calculate the dimensions for the small white rectangle (5% smaller)
    smallLeft = 20 + (200 * 0.05)
    smallTop = 20 + (120 * 0.05)
    smallWidth = 200 * 0.9
    smallHeight = 120 * 0.9
    
    'Add the small white Rectangle
    With ActiveSheet.Shapes.AddShape(Type:=msoShapeRectangle, Left:=smallLeft, Top:=smallTop, Width:=smallWidth, Height:=smallHeight)
        .Name = "innerRectangle"
    End With
    
    'Insert the flag inside the small white rectangle
    With ActiveSheet.Shapes("innerRectangle").Fill
        .UserPicture "https://upload.wikimedia.org/wikipedia/en/b/ba/Flag_of_Germany.svg"
    End With
    
End Sub
    • 1

相关问题