在VBA 2010上导出图像之前如何裁剪图像 [英] How to crop an image prior to exporting it on VBA 2010

问题描述

我有一个子例程工作很好，可以导出从excel范围中获取的图像，但我面临一个问题...即使我设法使图表对象透明，没有边框...导出图像在出口之前有很多未使用的区域。

  Sub BtnSaveFile_Click（）
 
 Dim RgExp As Range 
 Dim ImageToExport As Excel.ChartObject 
 
 Const sSlash $ =/
 Const sPicType $ =.png
 Dim sChartName $ 
 Dim sPath $ 
 Dim sBook $ 
 
设置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） 
 
带有ImageToExport.Chart.ChartArea.Format.Fill 
 .Visible = msoFalse 
结束
 
使用ImageToExport.Chart.ChartArea.Format.Line 
 .Visible = msoCFalse 
结束
 
 ImageToExport.Chart.Paste 
 
开始：
 
 sChartName = Application.InputBox（输入您的选择名称& vbCr& _ 
没有默认名称可用& vbCr& _ 
文件将被保存在C：\SECTIONIZER\SAVED SECTION\，为视图提供一个名称，）
 
如果sChartName =空然后
 MsgBox请输入文件名，无效输入
 GoTo开始
结束如果
 
如果sChartName =False然后
 ImageToExport 。删除
退出子
如果
 
 sBook =C：\SECTIONIZER\SAVED SECTION
 sPath = sBook& sSlash& sChartName& sPicType 
 ImageToExport.Chart.Export文件名：= sPath，FilterName：=PNG
 ImageToExport.Delete 
 
 ExitProc：
 Application.ScreenUpdating = True 
 Set ImageToExport = Nothing 
 Set RgExp = Nothing 
 
 End Sub 
  

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

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

从此： p>

为此：

解决方案

我设法解决了。首先，我将所有的形状组合在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 $ 
 
'选择和分组范围内的图像
设置RangeToTest = Range（G4：N28）
 
对于每个CC在RangeToTest 
 
设置ShpList = Sheets（SECTIONIZER）。形状
 
对于ShpList中的每个Shp 
如果CC.Address = Shp.TopLeftCell.Address然后
 Shp.Select替换：= False 
 End If 
 Next Shp 
 
下一个CC 
 
选择.ShapeRange.Group.Select 
 
'W和H与上面选择的组建立宽度和高度
 W = Selection.Width 
 H = Selection.Height 
 
'所选组被复制为图片
 Selection.CopyPicture xlScreen，xlPicture 
 
'图表对象被添加到W和H值
设置ImageToExport = ActiveSheet.ChartObjects 。添加（0，0，W，H）
 
带有ImageToExport.Chart.ChartArea.Format.Fill 
 .Visible = msoFalse 
结束
 
 With ImageToExport.Chart.ChartArea.Format.Line 
 .Visible = msoCFalse 
结束
 
'然后将所选的组粘贴到上面添加的图表
 ImageToExport中。 Chart.Paste 
 
开始：
'弹出窗口供用户输入文件名
 sChartName = Application.InputBox（输入您的选择名称& vbCr& _ 
没有默认名称可用& vbCr& _ 
文件将被保存在C：\SECTIONIZER\SAVED SECTION\，为视图提供名称，）
 
'用户按OK 没有输入名称
如果sChartName =空然后
 MsgBox请输入文件名，无效输入
 GoTo开始
结束如果
 
'如果按下取消按钮
如果sChartName =False然后
 ImageToExport.Delete 
退出子
结束如果
 
'如果A名称被给定，视图被导出为A * .PNG图像
'在C：\SECTIONIZER\SAVED SECTION 
 sBook =C：\SECTIONIZER\SAVED SECTION
 sPath = sBook& sSlash& sChartName& sPicType 
 ImageToExport.Chart.Export文件名：= sPath，FilterName：=PNG
 ImageToExport.Delete 
 
 ExitProc：
 Application.ScreenUpdating = True 
 Set ImageToExport = Nothing 
 Set RgExp = Nothing 
 
 End Sub 
  

I have a subroutine working just fine to export an image taken from a range in excel, but I´m facing a problem... Even when I managed to make the chart object transparent and without a border... the exported image has a lot of unused area that I wish to crop before exporting it.

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

I had the idea to crop it by seeking the first black pixel at each side of the image (left,top,right,bottom), so I can then set the coordinates to crop out the empty pixels, but I haven´t found a code to do so.

EDIT: added images from OP's supplied links

From this:

    

To this:

    

解决方案

I managed to solve it. First of all, I grouped all the shapes at the excel range, with the group selected, established W and H of the selection to later attribute it to the Width and Height of the Chart to be added, then on the added chart Pasted the Copied Selection... Here is the final outcome:

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

这篇关于在VBA 2010上导出图像之前如何裁剪图像的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！