将多个图像同时从Excel导出到我的工作簿

将多个图像同时从Excel导出到我的工作簿,excel,vba,export,Excel,Vba,Export,大家好,我叫毛里齐奥,我的问题是: 在Excel表格上,我插入了5个(形状)和其他图像。 下面是你的帖子: 我只能选择并导出工作簿中的一个图像;我想把它们一起出口 不管他们是否被选中,我这里的东西都少了。 你可以帮我一下。谢谢 毛里齐奥先生的问候 Sub Esporta_Immagini() Dim MyChart As String, MyPicture As String, oShape As Variant Dim PicWidth As Long, PicHeight

大家好,我叫毛里齐奥,我的问题是: 在Excel表格上,我插入了5个(形状)和其他图像。 下面是你的帖子:

我只能选择并导出工作簿中的一个图像;我想把它们一起出口 不管他们是否被选中,我这里的东西都少了。 你可以帮我一下。谢谢 毛里齐奥先生的问候

Sub Esporta_Immagini()
     Dim MyChart As String, MyPicture As String, oShape As Variant
     Dim PicWidth As Long, PicHeight As Long
     Dim strImageName
     Dim oDia
     Dim oChartArea  
     Application.ScreenUpdating = False
     On Error GoTo finish
     MyPicture = Selection.Name
     With Selection
           PicHeight = .ShapeRange.Height
           PicWidth = .ShapeRange.Width
     End With
     Charts.Add
     ActiveChart.Location WHERE:=xlLocationAsObject, Name:="Foglio1"
     Selection.Border.LineStyle = 0
     MyChart = Selection.Name & " " & Split(ActiveChart.Name, " ")(2)
     With ActiveSheet
           With .Shapes(MyChart)
                 .Width = PicWidth
                 .Height = PicHeight
                 .Copy
           End With
           .Shapes(MyPicture).Copy
           With ActiveChart
                 .ChartArea.Select
                 .Paste
           End With
           .ChartObjects(1).Chart.Export Filename:=ThisWorkbook.Path & "\Oggetti_Immagini_Salvate\MyPic1.jpg", FilterName:="jpg"
           .ChartObjects(1).Chart.Export Filename:=ThisWorkbook.Path & "\Oggetti_Immagini_Salvate\MyPic2.jpg", FilterName:="jpg"
           '.ChartObjects(1).Chart.Export Filename:=ThisWorkbook.Path & "\Oggetti_Immagini_Salvate\MyPic3.jpg", FilterName:="jpg"
           '.ChartObjects(1).Chart.Export Filename:=ThisWorkbook.Path & "\Oggetti_Immagini_Salvate\MyPic4.jpg", FilterName:="jpg"
           '.ChartObjects(1).Chart.Export Filename:=ThisWorkbook.Path & "\Oggetti_Immagini_Salvate\MyPic5.jpg", FilterName:="jpg"
           .Shapes(MyChart).Cut
     End With
     For Each oShape In ActiveSheet.Shapes
    strImageName = ActiveSheet.Cells(oShape.TopLeftCell.Row, 1).Value
    oShape.Select
    'Picture format initialization
    Selection.ShapeRange.PictureFormat.Contrast = 0.5: Selection.ShapeRange.PictureFormat.Brightness = 0.5:
    Selection.ShapeRange.PictureFormat.ColorType = msoPictureAutomatic:
    Selection.ShapeRange.PictureFormat.TransparentBackground = msoFalse: Selection.ShapeRange.Fill.Visible = msoFalse:
    Selection.ShapeRange.Line.Visible = msoFalse: Selection.ShapeRange.Rotation = 0#:
    Selection.ShapeRange.PictureFormat.CropLeft = 0#: Selection.ShapeRange.PictureFormat.CropRight = 0#:
    Selection.ShapeRange.PictureFormat.CropTop = 0#: Selection.ShapeRange.PictureFormat.CropBottom = 0#:
    Selection.ShapeRange.ScaleHeight 1#, msoTrue, msoScaleFromTopLeft:
    Selection.ShapeRange.ScaleWidth 1#, msoTrue, msoScaleFromTopLeft 
    '/Picture format initialization
    Application.Selection.CopyPicture
    Set oDia = ActiveSheet.ChartObjects.Add(0, 0, oShape.Width, oShape.Height)
    Set oChartArea = oDia.Chart
    oDia.Activate   
    With oChartArea.Export
        .ChartArea.Select
        .Paste
        .Export = ThisWorkbook.Path & ("\Oggetti_Immagini_Salvate\MyPic1.jpg" & strImageName & ".jpg")        
    End With
    oDia.Delete 'oChartArea.Delete
Next
     Application.ScreenUpdating = True
     Exit Sub
finish:
     MsgBox "Devi Selezionare Una Immagine"
End Sub