如何在VBA 2010上导出图像之前裁剪图像

Question

我有一个子程序正常工作，可以导出从excel范围内取得的图像，但我遇到了问题......即使我设法使图表对象透明且没有边框...导出图像有很多未使用的区域，我希望在导出之前进行裁剪。

Sub BtnSaveFile_Click()

Dim RgExp As Range
Dim ImageToExport As Excel.ChartObject

Const sSlash$ = "/"
Const sPicType$ = ".png"
Dim sChartName$
Dim sPath$
Dim sBook$

Set RgExp = Range("G4:N28")

RgExp.CopyPicture xlScreen, xlPicture

Set ImageToExport = ActiveSheet.ChartObjects.Add(Left:=RgExp.Left - 80, Top:=RgExp.Top - 80, Width:=RgExp.Width - 80, Height:=RgExp.Height - 80)

With ImageToExport.Chart.ChartArea.Format.Fill
.Visible = msoFalse
End With

With ImageToExport.Chart.ChartArea.Format.Line
.Visible = msoCFalse
End With

ImageToExport.Chart.Paste

Start:

sChartName = Application.InputBox("Enter A Name Of Your Choice" & vbCr & _
"There Is No Default Name Available" & vbCr & _
"The File Will Be Saved At C:\SECTIONIZER\SAVED SECTION\", "PROVIDE A NAME FOR THE VIEW", "")

If sChartName = Empty Then
MsgBox "Please Enter A File Name", , "Invalid Entry"
GoTo Start
End If

If sChartName = "False" Then
ImageToExport.Delete
Exit Sub
End If

sBook = "C:\SECTIONIZER\SAVED SECTION"
sPath = sBook & sSlash & sChartName & sPicType
ImageToExport.Chart.Export Filename:=sPath, FilterName:="PNG"
ImageToExport.Delete

ExitProc:
Application.ScreenUpdating = True
Set ImageToExport = Nothing
Set RgExp = Nothing

End Sub

我有想法通过在图像的每一侧（左，上，右，下）寻找第一个黑色像素来裁剪它，所以我可以设置坐标以裁剪出空像素，但我没有找到了这样做的代码。

编辑：从OP提供的链接中添加了图片

由此：

对此：

Answer 1

您需要启动宏录制器，然后将图片裁剪到您喜欢的区域，然后您可以使用子程序中记录的坐标。以下是您将获得的样本

Selection.ShapeRange.PictureFormat.Crop.PictureWidth = 196
Selection.ShapeRange.PictureFormat.Crop.PictureHeight = 196
Selection.ShapeRange.PictureFormat.Crop.PictureOffsetX = 0
Selection.ShapeRange.PictureFormat.Crop.PictureOffsetY = -8

Answer 2

我设法解决了这个问题。首先，我将所有形状分组在excel范围内，选择组，建立选择的W和H，然后将其归入要添加的图表的宽度和高度，然后在添加的图表上粘贴复制选择......以下是最终结果：

Sub BtnSaveFile_Click()

Dim ImageToExport As Excel.ChartObject
Dim Shp As Shape
Dim RangeToTest As Range
Dim CC As Range
Dim DD As Range

Const sSlash$ = "/"
Const sPicType$ = ".png"
Dim sChartName$
Dim sPath$
Dim sBook$

'The images at the range are selected and grouped 
Set RangeToTest = Range("G4:N28")

For Each CC In RangeToTest

    Set ShpList = Sheets("SECTIONIZER").Shapes

    For Each Shp In ShpList
        If CC.Address = Shp.TopLeftCell.Address Then
            Shp.Select Replace:=False
        End If
    Next Shp

Next CC

Selection.ShapeRange.Group.Select

'W and H are established with the above selected group Width and Height
W = Selection.Width
H = Selection.Height

'Selected group is copied as picture
Selection.CopyPicture xlScreen, xlPicture

'Chart Object is Added with the W and H values
Set ImageToExport = ActiveSheet.ChartObjects.Add(0, 0, W , H)

   With ImageToExport.Chart.ChartArea.Format.Fill
        .Visible = msoFalse
    End With

    With ImageToExport.Chart.ChartArea.Format.Line
        .Visible = msoCFalse
    End With

    'Group Selected is then Pasted into the above added Chart
    ImageToExport.Chart.Paste

Start:
         '   Pop Up Window For User To Enter File Name
        sChartName = Application.InputBox("Enter A Name Of Your Choice" & vbCr & _
        "There Is No Default Name Available" & vbCr & _
        "The File Will Be Saved At C:\SECTIONIZER\SAVED SECTION\", "PROVIDE A NAME FOR THE VIEW", "")

         '   User presses "OK" without entering a name
        If sChartName = Empty Then
            MsgBox "Please Enter A File Name", , "Invalid Entry"
            GoTo Start
        End If

         '   If Cancel Button Is Pressed
        If sChartName = "False" Then
            ImageToExport.Delete
            Exit Sub
        End If

         '   If A Name Was Given, View Is Exported As A *.PNG Image
         '   At C:\SECTIONIZER\SAVED SECTION
       sBook = "C:\SECTIONIZER\SAVED SECTION"
       sPath = sBook & sSlash & sChartName & sPicType
       ImageToExport.Chart.Export Filename:=sPath, FilterName:="PNG"
       ImageToExport.Delete

ExitProc:
Application.ScreenUpdating = True
Set ImageToExport = Nothing
Set RgExp = Nothing

End Sub