Cacher is the code snippet organizer for pro developers

插入图片
Sub add_pic1()
    c_add1 = fc("pic_series")
    fpath1 = ThisWorkbook.Path & "\img"
    '---
    On Error Resume Next
    Dim tmpRge As Range  '定义单元格
    Set SH = Sheets("Sheet1")
    
    SH.Select
    
    ' For Each SP In SH.Shapes '删除表中原来所有的图片
    '   SP.Delete
    ' Next
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    ARRGS = Split("BMP,RLE,PNG,JPG,", ",") '多种格式
    
    For i = 2 To SH.Range("A65536").End(xlUp).Row  
    '   If SH.Cells(i, 1) = "" Then Exit For
        SH.Range(convert1(c_add1) & i).Select    
        
        For X = 0 To UBound(ARRGS)
            STR1 = fpath1 & "" & Trim(SH.Cells(c_add1, 1)) & "." & ARRGS(X)
            If FSO.FileExists(STR1) = True Then
                SH.Pictures.Insert(STR1).Select
                With Selection
                    .Placement = xlMoveAndSize
                    .ShapeRange.LockAspectRatio = msoFalse
                    .Top = ActiveCell.Top + 1
                    .Left = ActiveCell.Left + 1
                    .Height = ActiveCell.Height + 1 '设置为“+1”，达到随单元格变化。若完全在单元格内部，那么其不会跟着单元格变化
                    .Width = ActiveCell.Width + 1
                End With
                Exit For  
            End If
        Next X
    Next i




http://club.excelhome.net/forum.php?mod=redirect&goto=findpost&ptid=1176048&pid=8018229

Sub zf()
    On Error Resume Next
    Application.ScreenUpdating = False
    ActiveSheet.DrawingObjects.Delete
    Dim i%
    Dim MR As Range

    For Each MR In Range("C2:h" & 5)
        If Not IsEmpty(MR) And MR <> &quot;无&quot; Then
            MR.Select
            ML = MR.Left + 4
            MT = MR.Top + 4
            MW = MR.Width * 0.9
            MH = MR.Height * 0.9
            ActiveSheet.Shapes.AddShape(msoShapeRectangle, ML, MT, MW, MH).Select
            Selection.ShapeRange.Fill.UserPicture _
            ActiveWorkbook.Path & &quot;\图片\&quot; & MR.Value & &quot;.jpg&quot;     '当前文件所在目录下以当前单元内容为名称的.jpg图片
        End If
    Next
    Application.ScreenUpdating = True
End Sub