|
本文所讲的，所插入的图片和位置，具有如下特性：
①所插入的图片名称，均有规律，每张图片的名称为身份证.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
没有相关教程
|
注：本站部分文章源于互联网，版权归原作者所有！如有侵权，请原作者与本站联系，本站将立即删除！ 本站文章除特别注明外均可转载，但需注明出处！ [MinTao学以致用网] 
