将多个图像同时从Excel导出到我的工作簿
大家好,我叫毛里齐奥,我的问题是: 在Excel表格上,我插入了5个(形状)和其他图像。 下面是你的帖子: 我只能选择并导出工作簿中的一个图像;我想把它们一起出口 不管他们是否被选中,我这里的东西都少了。 你可以帮我一下。谢谢 毛里齐奥先生的问候将多个图像同时从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
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