Sub 删除图片()
  Dim sh As Shape  '声明图形对象变量
  For Each sh In ActiveSheet.Shapes  '遍历本表所有图形对象
    If sh.Type = msoPicture Then  '如果是图片
      sh.Delete  '删除
    End If
  Next sh
End Sub

Sub 复制签名()
  Dim cell As Range, FirstAdd As String, ActiveShape As String
  '如果选择的对象不是图片则退出，否则复制当前对象
  If TypeName(Selection) <> "Picture" Then Exit Sub Else Selection.Copy
  ActiveShape = Selection.name
  '查找“制表签名：”
  Set cell = Cells.Find("制表签名：", lookat:=xlWhole)
  If Not cell Is Nothing Then '如果已找到
    FirstAdd = cell.Address '记录第一个找到的单元格的地址
    Do
      ActiveSheet.Paste  '粘贴图片
      With Selection '设置图片的位置，让图片比单元格稍小一点
        .Top = cell.Offset(0, 1).Top + 1
        .Left = cell.Offset(0, 1).Left + 1
        .Width = cell.Offset(0, 1).Width - 2
        .Height = cell.Offset(0, 1).Height - 2
      End With
      Set cell = Cells.FindNext(cell)  '查找下一个
    Loop Until cell.Address = FirstAdd  '直到找到的地址等于首个单元格地址
  End If
  ActiveSheet.Shapes(ActiveShape).Delete  '删除原有的图片
End Sub

Private Sub UserForm_Activate() '窗体激活时将活动单元格地址赋予文本框
  TextBox1 = ActiveCell.Address
End Sub
Private Sub CommandButton1_Click() '指定图片存放地址
  Dim rng As Range
  On Error Resume Next
star:
  Set rng = Application.InputBox("请选择单元格：", "图片查询存放地址",Active
  Cell.Address, , , , , 8)
  If Err <> 0 Then GoTo star '如果存在错误，则返回Star标签重新指定
  TextBox1 = rng(1).Address '将指定的区域中左上角单元格赋予文本框
End Sub
Private Sub CommandButton2_Click() '指定图片引用区域，多行多列
  Dim rng As Range
  On Error Resume Next
star:
 '让用户选择，默认是AB列已用区域
  Set rng = Application.InputBox("请选择存放图片名称的区域：", "图片引用源
  ", Intersect([a:b], Union([a1], ActiveSheet.UsedRange)).Address(0,
  0), , , , , 8)
  If Err <> 0 Then GoTo star '如果存在错误，则返回Star标签重新指定
  TextBox2 = rng.Address '将指定区域赋予文本框
End Sub
Private Sub SpinButton1_Change() '修改微调按钮时执行
  TextBox3 = SpinButton1.Value '文本框显示微调按钮的值
End Sub
Private Sub CommandButton3_Click() '根据上面的设定数据添加名称
  On Error Resume Next
  '防错，避免数据填写有误时无法正确执行
 If Len(TextBox1) = 0 Or Len(TextBox2) = 0 Or Len(TextBox3) = 0 Then MsgBox
"请填写完整！": Exit Sub
  If Range(TextBox2)(1) = "" Then MsgBox "请选择图片名称区域，不能空白。
  ",64:Exit Sub
  If Me.TextBox3.Value < 0 Or Me.TextBox3.Value > Columns.Count -
  ActiveCell.Column Then MsgBox "图片所在列超出有效范围！": Exit Sub
  ActiveWorkbook.Names("照片").Delete   '删除原有名称"照片"，如果有的话
  '添加名称，该名称根据TextBox1的值查找与它同名的图片所在单元格地址。
  ActiveWorkbook.Names.Add Name:="照片", RefersTo:="=OFFSET(" & Range
  (TextBox2)(1).Address & ",MATCH(" & TextBox1.Text & "," & Range
  (TextBox2).Resize(Range(TextBox2).Rows.Count, 1).Address & ",0)-1,"
  & Me.TextBox3.Value - 1 & ",1,)"
  With Range(TextBox1.Text).Validation
  '对TextBox1指定的单元格设置数据有效性
    .Delete '删除原有设置，添加新的引用，引用区域为TextBox2代表的区域中第一列
    .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:
    =xlBetween, Formula1:="=" & Range(TextBox2).Resize(Range(TextBox2).
    Rows.Count, 1).Address
    .InCellDropdown = True
    .ShowInput = True
  End With
  Range(TextBox1.Text).Value = Range(TextBox2)(1).Value '指定默认值
  Unload Me '关闭窗口
End Sub

Sub 引用图片()
 UserForm1.Show 0 '显示窗体
End Sub

Dim n As Integer, arr(), PathStr As String
Private Sub UserForm_Activate()  '激活窗体时执行过程
  Dim str As String, fd
  On Error GoTo err    '程序出错时则退出
  Set fd = Application.FileDialog(msoFileDialogFolderPicker)
  With fd  '显示一个选择文件夹的对话框，如果选择了文件夹则取其名称，否则退出
    If .Show = -1 Then PathStr = .SelectedItems(1) Else Exit Sub
  End With
  str = Dir(PathStr & "\*.jpg")  '开始查找文件，格式为所有jpg文件
  While Len(str) > 0
    n = n + 1  '累加变量，该变量代表文件数量
    ReDim Preserve arr(1 To n)  '重置数组范围
    arr(n) = Split(LCase(str), ".jpg")(0)  '将文件的后缀名去掉，然后导入数组中
    str = Dir()  '查找下一个
  Wend
  If n > 0 Then Me.ComboBox1.List = arr:  Me.ComboBox1.Text = arr(1)
'将数组的值赋予复合框
err:
End Sub
Private Sub ComboBox1_Change()  '修改复合框时执行
'如果复合框非空白，那么图像控件中调用与复合框中字符串同名的图片
  If Len(ComboBox1.Text) > 0 Then Image1.Picture = LoadPicture(PathStr &
IIf(Right(PathStr, 1) = "\", "", "\") & ComboBox1.Text & ".jpg")
End Sub

Sub 图片浏览()
UserForm1.Show 0
End Sub