Excel2010批量添加批注图片

后面个好像有点复杂，先做你前一个要求，有问题再追问

以下是代码部分（代码是模块级的，不要放在sheet下面）
'********************************************************************
Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Type BITMAP
bmType As Long
bmWidth As Long
bmHeight As Long
bmWidthBytes As Long
bmPlanes As Integer
bmBitsPixel As Integer
bmBits As Long
End Type
Type PicInfo
PicWidth As Long
picHeight As Long
End Type
Function GetPictureInfo(lsPicName As String) As PicInfo
Dim hBitmap As Long
Dim res As Long
Dim bmp As BITMAP
res = GetObject(LoadPicture(lsPicName).Handle, Len(bmp), bmp)
GetPictureInfo.PicWidth = bmp.bmWidth
GetPictureInfo.picHeight = bmp.bmHeight
End Function

Sub 批量插入同名照片到批注()
Application.ScreenUpdating = 0
Dim cell As Range, fd, t, Pic_W As Double, Pic_H As Double
Selection.ClearComments
On Error GoTo err
Set fd = Application.FileDialog(msoFileDialogFolderPicker) '允许用户选择一个文件夹
If fd.Show = -1 Then
t = fd.SelectedItems(1) '选择之后就记录这个文件夹名称
Else
Exit Sub '否则就退出程序
End If
Dim rg As Range
Set rg = Selection
For Each cell In rg
If cell <> "" Then
With cell.AddComment
.Visible = True
.Text Text:=""
.Shape.Select True
Pic_W = GetPictureInfo(t & "\" & cell.Text & ".jpg").PicWidth
Pic_H = GetPictureInfo(t & "\" & cell.Text & ".jpg").picHeight
Selection.ShapeRange.Fill.UserPicture t & "\" & cell.Text & ".jpg"
Selection.Width = Pic_W
Selection.Height = Pic_H
cell.Offset(1, 0).Select
.Visible = False
End With
End If
Next
Application.ScreenUpdating = 1
Exit Sub
err: ActiveCell.ClearComments
End Sub
'**********************************************************