商品人员工作必备 — 对应款号插入图片的操作
对应款号插入图片的操作
注意：单元格里的名字和图片必须一致
（检查图片的像素和大小，图片太大会造成机器卡死)
前言：很多人问我这个这么难能学会吗？代码也看不懂啊？解释一下原理啊？ 本人也不懂代码，本文中的代码是找朋友修改的。对以上问题我也解释不了，我的原则就是会用就行了，没有必要了解那么多问题。
友情提示大家：关于本文介绍的操作可以默认为傻瓜式操作就可以了。关于代码部分你只需要知道这个代码是干什么用的就可以了，相信我写的已经够详细了。如果大家在操作过程中发现问题，可以给我留言或者联系我，我会修正的。
对应款号插入图片一种是以批注的形式出现，这种方式更多的作为报表的辅助形式出现，一种是直接显示在表格内，这种是做商品目录，订单等识别性文件。
这种操作批量大，一个一个插入很费时间，使用代码就很简单，当然还有一些工具箱可以支持图片导入这里就不介绍了。
代码很难懂，所以我的原则就是会用就行，就不去了解代码原理了。
下面开始进行操作演示，首先你要选择插入图片的方式，这里以插入批注为例：
打开文件 选中要插入图片的区域，提示：不要直接选中列，尽量选中需要的区域否则运行候会很长时间，严重的会死机，因为语句会判断每一个空白单元格是否需要导入图片。
在工作簿的标签上 单击右键 查看代码
复制对应的代码到打开的VB编辑器里面（代码在本文的下半部分）
点击绿色箭头 或者F5
在打开的界面中选择图片存在的目录
在弹出的宽度和高度窗口中输入适合的尺寸
看看需要的效果出现了 ,如果大小不合适再重复一次上面的操作，注意更改图片大小直到合适为止。
最后一件事就是删除代码然后保存，提示：不清除代码并保存以后别人打开文件后会提示有宏存在，很多机器都是禁用宏的，或造成文件打不开或者图片显示不了等问题出现
第一种：插入批注
插入批注图片（可以选择存放文件夹，可以设定图片大小）
Sub pictopz()
Dim cell As Range, fd, t, w As Byte, h As Byte
Set fso = CreateObject(\"scripting.filesystemobject\")
Selection.ClearComments
If Selection(1) = \"\" Then MsgBox \"不能选择空白区。\提示\": Exit Sub
On Error GoTo err
Set fd = Application.FileDialog(msoFileDialogFolderPicker) '允许用户选择一个文件夹
If fd.Show = -1 Then
t = fd.SelectedItems(1) '选择之后就记录这个文件夹名称
Else
Exit Sub '否则就退出程序
End If
w = Application.InputBox(\"您希望插入的图片显示多宽？\" & Chr(10) & \"Excel默认宽度为3.39，你可以输入1-15之间的数据。\" & Chr(10) & \"小于1时当做1计算。\确认宽度\
h = Application.InputBox(\"您希望插入的图片显示多高？\" & Chr(10) & \"Excel默认高度为2.09，你可以输入1-15之间的数据。\" & Chr(10) & \"小于1时当做1计算。\确认高度\
If w < 1 Or h < 1 Then w = 3.39: h = 2.09
If w > 15 Or h > 15 Then MsgBox \"原则上你的图片可以显示这么大，\" & Chr(10) & \"不过有必要吗？请重新输入1-15之间的数\提示\": Exit Sub
For Each cell In Selection
pics = t & \"\\\" & cell.Text & \".jpg\"
If fso.fileexists(pics) Then
With cell.AddComment
.Visible = True
.Text Text:=\"\"
.Shape.Select True
With Selection.ShapeRange
.Fill.UserPicture pics
.ScaleWidth w / 3, msoFalse, msoScaleFromTopLeft
.ScaleHeight h / 2.09, msoFalse, msoScaleFromTopLeft
End With
cell.Offset(1, 0).Select
.Visible = False
End With
end if
Next
Exit Sub
err:
ActiveCell.ClearComments
MsgBox \"未找到同名的JPG图片！\提示\"
End Sub
插入批注图片（输入图片地址）
Sub add()
Set fso = CreateObject(\"scripting.filesystemobject\")
For Each cell In Selection
pics = \"请复制图片所在文件的地址粘贴在此处，替换本段文字\\\" & cell.Value & \".jpg\"
If fso.fileexists(pics) Then
With cell.AddComment
.Shape.Fill.UserPicture picturefile:=pics
.Shape.Height = 200
.Shape.Width = 150
End With
End If
Next cell
End Sub
第二种：直接显示在单元格
批量导入图片（可以选存放文件夹,可以选择图片的位置）
Sub AAA()
On Error Resume Next
Dim T As String, FD
Dim MR As Range
Set FD = Application.FileDialog(msoFileDialogFolderPicker) '允许用户选择一个文件夹
If FD.Show = -1 Then
T = FD.SelectedItems(1) '选择之后就记录这个文件夹名称
Else
Exit Sub '否则就退出程序
End If
p = InputBox(\"请选择图片插入位置，上，下，左，右依次用1，2，3，4代替\请选择位置\")
Set fso = CreateObject(\"scripting.filesystemobject\")
For Each MR In Selection
If Not IsEmpty(MR) Then
pic = T & \"\\\" & MR.Value & \".jpg\"
If fso.FileExists(pic) Then
MR.Select
If (p = 1) Then '上
ML = MR.Left
MT = MR.Top - MR.Height
MW = MR.Width
MH = MR.Height
ElseIf (p = 2) Then '下
ML = MR.Left
MT = MR.Top + MR.Height
MW = MR.Width
MH = MR.Height
ElseIf (p = 3) Then '左
ML = MR.Left - MR.Width
MT = MR.Top
MW = MR.Width
MH = MR.Height
ElseIf (p = 4) Then '右
ML = MR.Left + MR.Width
MT = MR.Top
MW = MR.Width
MH = MR.Height
End If
ActiveSheet.Shapes.AddShape(msoShapeRectangle, ML, MT, MW, MH).Select
Selection.ShapeRange.Fill.UserPicture pic '当前文件所在目录下以当前单元内容为名称的.jpg图片
End If
End If
Next
End Sub
批量导入图片（图片和文件必须在一个文件夹里）
Sub AAA()
On Error Resume Next
Dim MR As Range
Set fso = CreateObject(\"scripting.filesystemobject\")
For Each MR In Selection
If Not IsEmpty(MR) Then
pic = ActiveWorkbook.Path & \"\\\" & MR.Value & \".jpg\"
If fso.FileExists(pic) Then
MR.Select
ML = MR.Left + MR.Width
MT = MR.Top
MW = MR.Width
MH = MR.Height
ActiveSheet.Shapes.AddShape(msoShapeRectangle, ML, MT, MW, MH).Select
Selection.ShapeRange.Fill.UserPicture pic '当前文件所在目录下以当前单元内容为名称的.jpg图片
End If
End If
Next
End Sub
因篇幅问题不能全部显示，请点此查看更多更全内容