excel批量插入图片代码

18434309519

Sub InsertPic()
On Error Resume Next
Dim I As Long, sPath As String, sfileName As String
sPath = "E:\小图" '设置图片位置
Application.ScreenUpdating = Flase
For I = 2 To Cells(65536, 1).End(xlUp).Row '从第二行循环到有数据的最后一行
If Cells(I, 1) <> "" Then
sfileName = sPath & "\" & Cells(I, 1) & ".jpg"
With Cells(I, 2)
ActiveSheet.Shapes.AddPicture sfileName, True, True, .Left, .Top, .Width, .Height
End With
End If
Next I
Application.ScreenUpdating = True
Range("A1").Select
End Sub

以上是我无意中得到的一个excel批量插入图片的vba代码，但是插入的图片和自己的需求不一样，现在想改下。（其实想用excel图片百宝箱或者方方格子等插件了，奈何都要收费）需求如下：
1.设置图片可以随单元格的变动而改变大小和位置
2.图片纵横比锁定可以设置（比如图片高80，宽80 可以这个样子来设置）
3.怎么改代码可以实现批注插入图片，并且批注的纵横比也可以自由调整
总结：希望第一条和第二条的需求能与截图里面圈住的功能一样自由调整，望大神们给出建议，让批量插入图片不再有收费，让更多的人看到此贴从中受惠！！

wmqz.130

楼主，由于你没有附件，我提供一段我写的插入图片代码。你可按你需求进行修改。

1. Public Sub 插入图片()
   
2. Dim FileName As String
   
3. Dim rng As Range
   
4. For Each shp In Sheet1.Shapes
   
5. If shp.Type > 10 Then
   
6. shp.Delete
   
7. End If
   
8. Next
   
9. With Sheet1
   
10.     FileName = ThisWorkbook.path & "\生产单图签" & [v4] & ".jpg"
    
11.     If Dir(FileName) <> "" Then
    
12.     .Pictures.Insert(FileName).Select
    
13.     Set rng = Sheet1.Range("r27:y34")
    
14.         With Selection
    
15.         Selection.ShapeRange.LockAspectRatio = msoFalse  '是否锁定宽高
    
16.         .Top = rng.Top + 1
    
17.         .Left = rng.Left + 1
    
18.         .Width = rng.Width
    
19.         .Height = rng.Height
    
20.         .Placement = xlMoveAndSize
    
21.         End With
    
22.     Else
    
23.     MsgBox "当前编号订单没有图片!"
    
24.     End If
    
25. End With
    
26. End Sub

复制代码