国产一区二区欧美精品免费-欧美国产日韩在线视频-欧美亚洲国语精品一区二区-欧美激情五月综合啪啪-国产69精品麻豆久久久久-亚洲人成精品久久久久桥网站-欧美刺激肥熟在线视频-十七岁日本免费完整版BD-黑夜在线拖拽不卡第一页

Sub 導(dǎo)圖并命名()

On Error Resume Next

Dim OutputAddress As String

Dim MySheet As Worksheet

Dim MyRange As Range

Dim h As Integer

Dim w As Integer

OutputAddress = ThisWorkbook.Path & "\" '輸出文件夾地址

Set MySheet = Sheets("Sheet1") '圖片所在工作表

For Each MyShape In MySheet.Shapes '遍歷shape

    If MyShape.Type = 13 Then '若類型為圖片

        Set MyRange = MyShape.TopLeftCell '獲取圖片左上角所在單元格

        If Not Application.Intersect(MyRange, Range("B：B")) Is Nothing Then '

            w = MyShape.Width

            h = MyShape.Height

            MyShape.ScaleHeight 1, msoCTrue

            MyShape.ScaleWidth 1, msoCTrue

            Set MyChart = MySheet.ChartObjects.Add(0, 0, MyShape.Width, MyShape.Height).Chart '新建chart對象，設(shè)置大小，粘貼圖片

            MyShape.Copy

            MySheet.ChartObjects(Replace(MyChart.Name, MySheet.Name & " ", "")).Activate

            ActiveChart.Paste

            MyChart.Export OutputAddress & Cells(MyRange.Row, "A").Value & ".jpg", "JPG" '導(dǎo)出

            MyChart.Parent.Delete '刪除chart對象

            MyShape.Width = w

            MyShape.Height = h

        End If

        Set MyRange = Nothing

    End If

Next MyShape

Application.ScreenUpdating = True

MsgBox "導(dǎo)出圖片完成！" & Chr(13) & "導(dǎo)出圖片所在的路徑：" & Chr(13) & sfolder, , "提示"

End Sub

用這個也導(dǎo)不出來  ，求助求助

回復(fù)：3樓