Question

在Excel文件中插入图像错误

无法显示链接的图像。该文件可能已被移动，重命名或删除。验证链接指向正确的文件和位置

当我与其他人分享并且按照宏中提到的代码使用时，

即将到来。我请你帮忙。（我使用的是Windows 10和Excel 10）

Sub Macro1()
'
' Macro1 Macro
'
' Keyboard Shortcut: Ctrl+p
'
Dim pictureNameColumn   As String 'column where picture name is found
Dim picturePasteColumn  As String 'column where picture is to be pasted

Dim pictureName         As String 'picture name
Dim lastPictureRow      As Long   'last row in use where picture names are
Dim pictureRow          As Long   'current picture row to be processed
Dim pathForPicture      As String 'path of pictures

pictureNameColumn = "A"
picturePasteColumn = "E"

pictureRow = 5 'starts from this row

'error handler
On Error GoTo Err_Handler

'find row of the last cell in use in the column where picture names are
lastPictureRow = Cells(Rows.Count, pictureNameColumn).End(xlUp).Row

'stop screen updates while macro is running
Application.ScreenUpdating = False

pathForPicture = "C:\Users\Nimit\Desktop\Dimensional\Insert Image\"
'loop till last row
Do While (pictureRow <= lastPictureRow)

    pictureName = Cells(pictureRow, "A") 'This is the picture name

    'if picture name is not blank then
    If (pictureName <> vbNullString) Then

        'check if pic is present

        'Start If block with .JPG
        If (Dir(pathForPicture & pictureName & ".jpg") <> vbNullString) Then

            Cells(pictureRow, picturePasteColumn).Select 'This is where picture will be inserted
            ActiveSheet.Pictures.Insert(pathForPicture & pictureName & ".jpg").Select 'Path to where pictures are stored

            With Selection
                .Left = Cells(pictureRow, picturePasteColumn).Left
                .Top = Cells(pictureRow, picturePasteColumn).Top
                .ShapeRange.LockAspectRatio = msoFalse
                .ShapeRange.Height = 45#
                .ShapeRange.Width = 55#
                .ShapeRange.Rotation = 0#
            End With
        'End If block with .JPG

        'Start ElseIf block with .PNG
        ElseIf (Dir(pathForPicture & pictureName & ".png") <> vbNullString) Then

            Cells(pictureRow, picturePasteColumn).Select 'This is where picture will be inserted
            ActiveSheet.Pictures.Insert(pathForPicture & pictureName & ".png").Select 'Path to where pictures are stored

            With Selection
                .Left = Cells(pictureRow, picturePasteColumn).Left
                .Top = Cells(pictureRow, picturePasteColumn).Top
                .ShapeRange.LockAspectRatio = msoFalse
                .ShapeRange.Height = 45#
                .ShapeRange.Width = 50#
                .ShapeRange.Rotation = 0#
            End With
        'End ElseIf block with .PNG

        'Start ElseIf block with .BMP
        ElseIf (Dir(pathForPicture & pictureName & ".bmp") <> vbNullString) Then

            Cells(pictureRow, picturePasteColumn).Select 'This is where picture will be inserted
            ActiveSheet.Pictures.Insert(pathForPicture & pictureName & ".bmp").Select 'Path to where pictures are stored

            With Selection
                .Left = Cells(pictureRow, picturePasteColumn).Left
                .Top = Cells(pictureRow, picturePasteColumn).Top
                .ShapeRange.LockAspectRatio = msoFalse
                .ShapeRange.Height = 45#
                .ShapeRange.Width = 50#
                .ShapeRange.Rotation = 0#
            End With
        'End ElseIf block with .BMP

        Else
            'picture name was there, but no such picture
            Cells(pictureRow, picturePasteColumn) = "No Picture Found"
        End If

    Else
    'picture name cell was blank
    End If
    'increment row count
    pictureRow = pictureRow + 1
Loop

Exit_Sub:
Range("A10").Select
Application.ScreenUpdating = True
Exit Sub

Err_Handler:
MsgBox "Error encountered. " & Err.Description, vbCritical, "Error"
GoTo Exit_Sub

End Sub

Answer 1

scroll view始终插入图片作为文件的引用。如果其他计算机上缺少图片文件（共享Excel文件时），则无法显示。

要将图片永久插入Excel文件，请尝试以下操作：

ActiveSheet.Pictures.Insert

请参阅此处查看reference to the Shapes.AddPicture method。

图片未插入Excel文件（但仅作为参考）

1 个答案: