VBA应用示例：根据工作表中的信息制作带图像的人员卡片（扩展版）

Sub Name_Shapes()
 Dim shp As Shape, sh1 As Worksheet, i As Long
 Set sh1 = Worksheets("Sheet1")
 For Each shp In sh1.Shapes
   For i = 2 To sh1.Cells(sh1.Rows.Count, 6).End(xlUp).Row
     If shp.TopLeftCell = Cells(i, 6).Address Then shp.Name = shp.TopLeftCell.Offset(, 1).Value: Exit For
   Next i
 Next shp
End Sub

Sub New_Folder()
 Dim Temp_Folder As String, IsItThere As String
 Temp_Folder = "C:\AAAAA_Names"
 IsItThere = Dir(Temp_Folder, vbDirectory)
 If IsItThere = "" Then MkDir Temp_Folder
End Sub

Sub Save_Picture_From_Sheet()
 Dim people
 Dim myPic As Shape
 Dim i As Long
 Dim tempChartObj As ChartObject
 Dim savePath As String
 people = Sheets("Sheet1").Range("G2:G9").Value
 If Dir("C:\AAAAA_Names", vbDirectory) = "" Then MsgBox "Make Folder First!": Exit Sub
 Application.ScreenUpdating = False
 For i = LBound(people) To UBound(people)
   Set myPic = Sheets("Sheet1").Shapes(people(i, 1))
   Set tempChartObj = Sheets("Sheet1").ChartObjects.Add(0, 0, myPic.Width, myPic.Height)
   savePath = "C:\AAAAA_Names\" & people(i, 1) & ".jpg"
   myPic.Copy
   DoEvents
   DoEvents
   tempChartObj.Chart.ChartArea.Select
   DoEvents
   DoEvents
   tempChartObj.Chart.Paste
   DoEvents
   DoEvents
   tempChartObj.Chart.Export savePath
   DoEvents
   DoEvents
   tempChartObj.Delete
 Next i
 Application.ScreenUpdating = True
End Sub

Sub Delete_New_Folder()
 If Dir("C:\AAAAA_Names", vbDirectory) = "" Then MsgBox "This folder was deleted already!": Exit Sub
 CreateObject("Scripting.FileSystemObject").DeleteFolder "C:\AAAAA_Names"
End Sub

Sub Insert_Rectangles_Pictures()
 If Dir("C:\AAAAA_Names", vbDirectory) = "" Then MsgBox "No folder with pictures on the ""C"" drive!": Exit Sub
 Dim w As Double, h As Double
 Dim k As Long, j As Long, i As Long
 Dim people
 w = Sheets("Sheet2").Columns(5).Left - Sheets("Sheet2").Columns(3).Left
 h = Sheets("Sheet2").Rows("12").Top - Sheets("Sheet2").Rows("6").Top
 k = 1
 people = Sheets("Sheet1").Range("G2:G9").Value
 For j = 6 To 23 Step 17
   For i = 3 To 18 Step 5
     With Sheets("Sheet2")
       .Shapes.AddShape(msoShapeRectangle, .Cells(j, i).Left, .Cells(j, i).Top, w, h).Name = "Rectangle " & k
       With .Shapes("Rectangle" & k)
         .Line.Visible = False
         .Fill.UserPicture ("C:\AAAAA_Names\" & people(k, 1) & ".jpg")
       End With
     End With
     k = k + 1
   Next i
 Next j
End Sub

Sub Delete_Pics_And_Rectangles()
 Dim i As Long, shp As Shape
 For i = 1 To 8
   On Error Resume Next
   Set shp = ActiveSheet.Shapes("Rectangle " & i): If Not shp Is Nothing Then shp.Delete
   On Error GoTo 0
 Next i
End Sub