excel vba自动图片导入

假设图片放在D盘根目录名为test的文件夹中，则可使用下列VBA代码自动插入图片：

Sub Insertpic()

Shell ("cmd /c dir ""D:\test"" /a:-d /b >""D:\2888.txt")

Application.Wait (Now + TimeValue("0:00:01"))

Sheet2.Select

With ActiveSheet.QueryTables.Add(Connection:="TEXTD:\2888.txt", _

Destination:=Range("$A$1"))

.Name = "1"

.FieldNames = True

.RowNumbers = False

.FillAdjacentFormulas = False

.PreserveFormatting = True

.RefreshOnFileOpen = False

.RefreshStyle = xlInsertDeleteCells

.SavePassword = False

.SaveData = True

.AdjustColumnWidth = True

.RefreshPeriod = 0

.TextFilePromptOnRefresh = False

.TextFilePlatform = 936

.TextFileStartRow = 1

.TextFileParseType = xlDelimited

.TextFileTextQualifier = xlTextQualifierDoubleQuote

.TextFileConsecutiveDelimiter = False

.TextFileTabDelimiter = True

.TextFileSemicolonDelimiter = False

.TextFileCommaDelimiter = False

.TextFileSpaceDelimiter = False

.TextFileColumnDataTypes = Array(1)

.TextFileTrailingMinusNumbers = True

.Refresh BackgroundQuery:=False

End With

d = Sheet2.Range("A10000").End(xlUp).Row

a = Sheet2.Cells(1, 1)

Sheet3.Select

ActiveSheet.Pictures.Insert ("D:\test\" &a)

b = ActiveSheet.Shapes(1).Width

c = ActiveSheet.Shapes(1).Height

m = Sheet1.Range("A1").Width / Sheet1.Columns(1).ColumnWidth

n = b / m

Sheet1.Columns("A:A").ColumnWidth = n

m = Sheet1.Range("A1").Width / Sheet1.Columns(1).ColumnWidth

n = b / m

Sheet1.Columns("A:A").ColumnWidth = n

m = Sheet1.Range("A1").Width / Sheet1.Columns(1).ColumnWidth

n = b / m

Sheet1.Columns("A:Z").ColumnWidth = n

Sheet1.Rows("1:10000").RowHeight = c

e = Int(960 / b)

For i = 1 To d

f = Int(i / e) + 1

If f = Int((i - 1) / e) + 2 Then

f = f - 1

End If

g = i Mod e

If g = 0 Then

g = e

End If

a = Sheet2.Cells(i, 1)

Sheet1.Shapes.AddPicture _

"D:\test\" &a, _

True, True, (g - 1) * b, (f - 1) * c, b, c

Next i

Sheet1.Select

End Sub

说明：1.上述代码可自动识别图片名称及图片尺寸，自动识别图片数量等；

2.必须以管理员账户登录电脑，才能成功执行上述代码；

3.需要放到"thisworkbook"的VBA编辑框才能运行；

4.执行该代码会在D盘根目录中生成一个名为2888的txt格式文件，运行完成后，可删除该文件；

5.每张图片尺寸不能超过320*546像素，若超过，则不能成功执行代码，可将图片文件夹的图片按名称排序后，将第一张图片的尺寸改小到上述尺寸以内，再执行代码；

6.图片数量超过10000张时，上述代码需要做适当修改。

1、打开Excel，准备好表格。

2、在工作表中，点击菜单栏【开发工具】，在其工具栏内，点击【visual basic】。

3、接着点击菜单栏【插入】，在其下拉菜单中，选择【模块】。

4、在d出模块编辑窗口填入代码：Sub 导入图片()Dim sp As Shape, rng As Range, rg As Range, arg As RangeFor Each sp In Sheets("插入图片").ShapesIf sp.Type <>8 Thensp.Delete

Next spSet arg = Columns("a").End(xlDown)For Each rng In Range([a2], arg)pah = thisworkbook.Path &"\tupian\" &rng.Value &".jpg"。

5、在工作表的【开发工具】菜单下，插入一【表单】按钮，并与指定编写的插入图片代码关联，且进入命名为【导入图片】。

6、点击【导入图片】按钮，图片被瞬间导入。就完成了。

批量插入图片代码：

sub 图片导入

dim s as shape

dim rg as range

'删除已有的图片

for each s in activesheet.shapes

if s.type <>8 then

s.delete

end if

'导入图片

for each rg in range("B2:B10")'这里放要插入图片的单元格范围 B2:B10可以改成所需要的范围。

activesheet.shapes.addshape(msoshaperectangle,rg.left,rg.top,rg.width,rg.height).select

selection.shaperange.fill.userpicture "E:\图片"&rg.offset(0, -1) &".jpg"'这里指定的是图片的存储路径为E盘下的图片文件夹，然后图片名称与A列的数据一致，后缀名为JPG格式。这些都可以自行更改，根据需要来定。

next rg

end sub

---