如何在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

我設法解決它。首先，我將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 

Answer 2

您需要啓動宏錄製然後將圖片裁剪到a你喜歡的東西，然後你可以使用你的子程序中記錄的座標。以下是你將得到的樣品

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