图片导入批注后保存时出错

ktsli

小弟遇到一个很棘手的问题，就是用代码将图片导入到批注中，一切正常，效果也很满意，但是保存时就由错误提示，保存不了，复制出来保存也是出错。当数据有50行左右时可以保存，不报错，但是数据到100行左右时保存就出错了，小弟不明白了，就算是文件太大，只要硬盘空间足够，那也是能保存的，不知道为什么会出错。错误提示是：“保存F:\工作簿1.xlsx时检测到错误，Microsoft Excel可以通过删除或修复某些来保存此文件，若要修复，单击继续，若取消保存，单击取消”，请各位老师指导一下，为什么会这样，该怎么解决这个问题，谢谢了！！！

qh8600

可能是有的图片是只读文件

zjdh

发附件看看

ktsli

Sub 导入图片到批注()
    Dim cell As Range, fd, t, FilPath$
    Dim X As Long
    Dim Y As Long
    Dim mystr As String
    On Error Resume Next
    Sheets("TP").Activate
     Y = Range("a10000").End(xlUp).Row
     For X = 2 To Y
       Range("A" & X).ClearComments
     Next X
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)    '选择一个文件夹
    If fd.Show = -1 Then
        t = fd.SelectedItems(1)
    Else
        Exit Sub
    End If
    mystr = InputBox("输入批注外形序号" & Chr(10) & "1 矩形, 2 书卷, 3 横卷, 4 竖卷" & Chr(10) & "5 椭圆, 6 菱形, 7 柱形, 8 圆矩", "选择批注外形", 8)
    If mystr = "" Then
      Exit Sub
    End If
    For Each cell In Range("A2:A" & Y)
        FilPath = t & "\" & cell.Text & ".jpg"
        If Dir(FilPath) <> "" Then
            With cell.AddComment
                .Visible = True
                .Text Text:=""
                .Shape.Select True
                 Selection.ShapeRange.AutoShapeType = Choose(mystr, msoShapeRectangle, msoShapeFoldedCorner, msoShapeHorizontalScroll, _
                 msoShapeVerticalScroll, msoShapeOval, msoShapeDiamond, msoShapeCan, msoShapeRoundedRectangle)
                 Selection.ShapeRange.Fill.UserPicture t & "\" & cell.Text & ".jpg"
                .Shape.Width = 90
                .Shape.Height = 90
                .Visible = False
            End With
        End If
    Next
End Sub

ktsli

ktsli 发表于 2014-6-6 15:10
Sub 导入图片到批注()
    Dim cell As Range, fd, t, FilPath$
    Dim X As Long

这是导入的程序，根据运行结果来看，程序应该是正确的，就是行数一多，保存时报错