本文所讲的,所插入的图片和位置,具有如下特性:
①所插入的图片名称,均有规律,每张图片的名称为身份证.jpg
②插入图片的尺寸为规定的大小
③图片位置为单元格内身份这号码下面的第二个单元格
代码如下:
Sub InserPic() Dim Shp As Shape Dim x As Integer, y As Integer '记录已使用区域的最大行号、列号 Dim i As Integer, u As Integer Dim R As Range Dim NW As Single, NH As Single '记录图片准备要更改的尺寸
On Error Resume Next '忽略错误继续执行VBA代码,避免出现错误消息 Application.ScreenUpdating = False '加入图片前清空已有图片 For Each Shp In ActiveSheet.Shapes If Shp.Type = msoPicture Then Shp.Delete Next
Set R = ActiveSheet.UsedRange x = ThisWorkbook.ActiveSheet.UsedRange.Rows.Count '取得已使用区域最大行号 y = ThisWorkbook.ActiveSheet.UsedRange.Columns.Count '取得已使用区域最大列号 For i = 1 To x For u = 1 To y If Not (Cells(i, u).Text = "") Then If Not (Dir(ThisWorkbook.Path & "\" & Cells(i, u).Text & ".jpg") = "") Then ActiveSheet.Pictures.Insert(ActiveWorkbook.Path & "\" & Cells(i, u) & ".jpg").Select Selection.ShapeRange.LockAspectRatio = msoFalse '设定图片的位置、尺寸(按单元格大小,并保持长宽比) With Selection NW = Cells(i + 2, u).Height / .Height '图片高度与单元格高度比例 NH = Cells(i + 2, u).Width / .Width '图片宽度与单元格宽度比例 If NW * .Width <= Cells(i + 2, u).Width Then '如果按高度比例缩小后的图片宽度小于等于单元格宽度,则按单元格高度为标准缩小比例插入图片 .Top = Cells(i + 2, u).Top If NW * .Width < Cells(i + 2, u).Width Then .Left = Cells(i + 2, u).Left + (Cells(i + 2, u).Width - NW * .Width) / 2 Else .Left = Cells(i + 2, u).Left End If .Height = Cells(i + 2, u).Height .Width = .Width * NW Else .Top = Cells(i + 2, u).Top .Left = Cells(i + 2, u).Left .Height = .Height * NH .Width = Cells(i + 2, u).Width End If End With End If End If Next u 'i = i + 1 Next i
Application.ScreenUpdating = True On Error GoTo 0 '恢复正常错误提示 End Sub
相关知识扩展:
'清空已有图片 Sub DelPic() Dim Shp As Shape
For Each Shp In ActiveSheet.Shapes If Shp.Type = msoPicture Then Shp.Delete Nextnd Sub |