Question

我的代码一直在运行，但突然之间却没有。我已经尝试了一切，无法弄清楚原因。它在我一步一步（F8）时起作用，但在我运行代码时却不起作用。代码正在做的是在B列中找到一个ID，找到具有相同图像的jpg（在文件H：\ Images ...中）并将其粘贴到第1列。代码生成错误“运行时错误1004：工作表类的PasteSpecial方法失败”并突出显示ActiveSheet.PasteSpecial行。请帮忙！

Sub Picture()
 Dim picname As String

Dim lThisRow As Long

lThisRow = 3

Do While (Cells(lThisRow, 2) <> "")

    Cells(lThisRow, 1).Select 'This is where picture will be inserted


     picname = Cells(lThisRow, 2) 'This is the picture name
    'MsgBox (picname)

    Dim DirFile As String
    DirFile = "H:\Images\9 Thumbnails\" & picname & ".jpg"
    If Len(Dir(DirFile)) = 0 Then
      'MsgBox "File does not exist"

    Else
        ActiveSheet.Pictures.Insert("H:\Images\9 Thumbnails\" & picname & ".jpg").Select
        Selection.Cut

    ActiveSheet.PasteSpecial Format:="Picture (JPEG)", Link:=False, _
        DisplayAsIcon:=False

     'Set WB = Workbooks.Open(DirFile)
             With Selection
                .ShapeRange.ScaleHeight 0.9, msoTrue
                .Left = Cells(lThisRow, 1).Left + Cells(lThisRow, 1).Width / 2 - Selection.ShapeRange.Width / 2
                .Top = Cells(lThisRow, 1).Top + Cells(lThisRow, 1).Height / 2 - Selection.ShapeRange.Height / 2

                '.ShapeRange.LockAspectRatio = msoFalse

                ''.ShapeRange.Width = 80#
                .ShapeRange.Rotation = 0#
            End With
    End If

lThisRow = lThisRow + 1
Loop

Range("B3").Select
On Error GoTo 0
Application.ScreenUpdating = True

Exit Sub

End Sub

Answer 1

我用.addpicture找出了答案。这改变了你看待尺寸的方式，但我也想出来了。最终代码：

Sub Picture()
 Dim picname As String
 Dim PicPath As String
 Dim lThisRow As Long
 Dim Pic As Shape
 Dim rngPic As Range


lThisRow = 3

Do While (Cells(lThisRow, 2) <> "")

    Set rngPic = Cells(lThisRow, 1) 'This is where picture will be inserted

    picname = Cells(lThisRow, 2) 'This is the picture name

    present = Dir("H:\Images\8 Thumbnails\" & picname & ".jpg")
    PicPath = ("H:\Images\8 Thumbnails\" & picname & ".jpg")

    If present <> "" Then

      Set Pic = ActiveSheet.Shapes.AddPicture(PicPath, msoFalse, msoCTrue, 1, 1, -1, -1)

      With Pic
        .LockAspectRatio = msoTrue
        If .Height < 45 Then .Height = 115
        If .Width > 150 Then .Width = 150
        .Left = rngPic.Left + rngPic.Width / 2 - Pic.Width / 2
        .Top = rngPic.Top + rngPic.Height / 2 - Pic.Height / 2
      End With

    Else

    Cells(lThisRow, 1) = ""

    End If

lThisRow = lThisRow + 1
Loop

Range("B3").Select
On Error GoTo 0
Application.ScreenUpdating = True

Exit Sub

End Sub

vba excel：JPEG的PasteSpecial不起作用

1 个答案: