Question

您好我想更改注释形状图片（填充）的文件格式以及标准高度和宽度。尝试了以下代码，但它继续抛出应用程序定义的错误＆＃34;运行时错误1004＆＃34;。请指导我纠正这个。

Sub ReduceImageSize()

    Dim cmt As Comment
    Dim MyChart As Chart
    Dim MyPicture As String
    Dim pic As Object
    Dim PicWidth As Long
    Dim PicHeight As Long
    Dim num As Long
    num = 1
    Application.ScreenUpdating = False
    For Each cmt In ActiveSheet.Comments
        With cmt
            .Visible = True
            .Shape.CopyPicture Appearance:=xlScreen, Format:=xlPicture
            .Visible = False
            PicHeight = .Shape.Height
            PicWidth = .Shape.Width

           Set MyChart = Charts.Add(0, 0, 100, 100).Chart
                With MyChart.Parent
                    .Width = PicWidth
                    .Height = PicHeight
                    .ChartArea.Select
                    .Paste
                    .ChartObjects(1).Chart.Export Filename:="C:\Temp\MyPic " & num & ".jpg", FilterName:="jpg"
                End With
                .Shape.Fill.UserPicture PictureFile:="C:\Temp\MyPic " & num - 1 & ".jpg"
                num = num + 1
                ActiveChart.Delete

            End With

    Next
    Application.ScreenUpdating = True
End Sub

Answer 1

尝试将格式：= xlPicture更改为格式：= xlBitmap，因为jpg是位图类型图像。请参阅MS中的以下内容。 https://msdn.microsoft.com/en-us/library/office/ff837557.aspx

还有https://msdn.microsoft.com/en-us/library/office/ff195475.aspx

Answer 2

找到解决方案：

Option Explicit
Sub ReduceImageSize()
    Dim cmt As Comment
    Dim MyChart As ChartObject
    Dim MyPicture As String
    Dim pic As Object
    Dim PicWidth As Long
    Dim PicHeight As Long
    Dim num As Long
    Dim Mysheet As Worksheet
     num = 1
    Application.ScreenUpdating = False
    For Each Mysheet In ThisWorkbook.Worksheets
     For Each cmt In ActiveSheet.Comments
        With cmt
            .Visible = True
            .Shape.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
            .Visible = False
            PicHeight = .Shape.Height
            PicWidth = .Shape.Width

           Set MyChart = ActiveSheet.ChartObjects.Add(0, 0, 100, 100)
                With MyChart
                    .Activate
                    .Width = PicWidth
                    .Height = PicHeight
                    .Chart.Paste
                    '.ChartArea.Select
                    '.Paste
                    .Chart.Export Filename:="C:\Temp\MyPic " & num & ".jpg", FilterName:="jpg"
                End With
                .Shape.Fill.UserPicture PictureFile:="C:\Temp\MyPic " & num & ".jpg"
                num = num + 1
                MyChart.Delete
            End With
      Next
      Application.ScreenUpdating = True
    Next
End Sub

更改Excel注释形状图片文件格式

2 个答案: