|
本帖最后由 lsdkln 于 2018-8-15 14:50 编辑
Sub rtian()
For Each pic In ActiveSheet.Shapes
If pic.Type = 13 Then
pic.Copy
With ActiveSheet.ChartObjects.Add(0, 0, pic.Width * 2, pic.Height * 2)
.Activate
.Chart.Paste
.ShapeRange.Width = pic.Width * 2
.ShapeRange.Height = pic.Height * 2
.Chart.Shapes(1).ScaleWidth 2, msoFalse, msoScaleFromTopLeft
.Chart.Export ThisWorkbook.Path & "\" & Cells(pic.TopLeftCell.Row, pic.TopLeftCell.Column - 1) & ".jpg"
.Delete
End With
End If
Next
End Sub
是不是用的excel2016的原因 下面这个也是出错无法运行
Sub yy()
Dim p As Shape, a$
For Each c In Range([a2], [a65536].End(3))
a = c.Value
c(1, 2).CopyPicture
With ActiveSheet.ChartObjects.Add(0, 0, c.Width, c.Height).Chart
.Paste
.Export "\" & a & ".jpg", "JPG"
.Parent.Delete
End With
Next
End Sub
这个以前office2016 我也可以用的,现在也不可以用了
Sub sExportShp2GIF()
Dim objShp As Shape, H, W, sku
Dim i As Integer
Dim c As ChartObject
For i = 1 To ActiveSheet.Shapes.Count
Set objShp = ActiveSheet.Shapes(i)
sku = ActiveSheet.Cells(objShp.TopLeftCell.Row, objShp.TopLeftCell.Column - 1)
W = objShp.Width
H = objShp.Height
objShp.Width = 1536
objShp.Height = 2048
objShp.CopyPicture
Set c = ActiveSheet.ChartObjects.Add(0, 0, objShp.Width, objShp.Height)
c.Activate
c.Chart.Paste
c.Chart.Export ThisWorkbook.Path & "\" & sku & ".jpg"
c.Delete
objShp.Width = W
objShp.Height = H
Next i
Set objShp = Nothing
End Sub
|
|