Sub 批量插入同名照片到批注()

Dim cell As Range, fd As FileDialog, 路径 As String, 宽 As Integer, 高 As Integer, rng As Range, typename As Integer, str As String

restar:

typename = Application.InputBox("输入1:插入GIF图片；" + Chr(10) + "输入2:插入PNG图片；" + Chr(10) + "输入3:插入JPG图片；" + Chr(10) + "输入4:插入TIF图片；" + Chr(10), "图片格式", 3, , , , , 1)

If typename < 1 Or typename > 4 Then MsgBox "输入错误": GoTo restar

str = VBA.Choose(typename, "*.GIF", "*.PNG", "*.JPG", "*.TIF") '根据输入的数字确定图片格式

Set rng = Application.Intersect(ActiveSheet.UsedRange, Selection)

Set fd = Application.FileDialog(msoFileDialogFolderPicker)

If fd.Show = -1 Then 路径 = fd.SelectedItems(1) Else Exit Sub '如果选择路径，提取路径全名，否则推出程序

If rng(1) = "" Then MsgBox "不能选择空白区", 64, "提示": Exit Sub

On Error Resume Next

rng.ClearComments '清除原批注

Err.Clear

star:

宽 = Application.InputBox("输入批注宽度" & Chr(10) & "EXCEL参考宽度为2.09", 2.09, , , , , 2)

高 = Application.InputBox("输入批注高度" & Chr(10) & "EXCEL参考高度为3.39", 3.39, , , , , 2)

If Err <> 0 Then Err.Clear: MsgBox "输入不规范，请重新输入": GoTo star

Application.ScreenUpdating = False

For Each cell In rng

If Dir(路径 & "\" & cell.Text & Mid(str, 2)) <> "" Then

With cell.AddComment

.Visible = True '可见性为TRUE

.Text Text:="" '不显示文本

.Shape.Select True '选择批注

With Selection.ShapeRange

.Fill.UserPicture 路径 & "\" & cell.Text & Mid(str, 2) '填充批注

.ScaleWidth 宽 / 3.39, msoFalse, msoScaleFromTopLeft '设置宽度

.ScaleHeight 高 / 2.09, msoFalse, msoScaleFromTopLeft '设置高度

End With

cell.Offset(1, 0).Select '选择单元格

.Visible = False '批注不可见

End With

GoTo nexts '运行a标签之语句

End If

MsgBox "未找到" & cell.Text & Mid(str, 2), 64, "提示"

ActiveCell.ClearComments '清除批注

cell.Offset(1, 0).Select '选择下一单元格

nexts:

Next

Application.ScreenUpdating = True

End Sub

批量导入批注