Excel批量插入图片求助
发布网友
共2个回答
热心网友
Dim ArrFiles(1 To 10000)
Dim cntFiles%Public Sub ListAllFiles()
'得到图片名字
Dim strPath$
Dim i%
Dim fso As New FileSystemObject, fd As Folder
strPath = ThisWorkbook.Path & "\"
cntFiles = 0
Set fd = fso.GetFolder(strPath)
SearchFiles fd
Sheet2.Cells.Clear
Sheet2.Range("A1").Value = "图片名称"
Sheet2.Range("A2").Resize(cntFiles) = Application.Transpose(ArrFiles)
End Sub
Sub SearchFiles(ByVal fd As Folder)
Dim fl As File
Dim sfd As Folder
For Each fl In fd.Files
cntFiles = cntFiles + 1
ArrFiles(cntFiles) = fl.Name
Next fl
End Sub
Function FileExists(strPath As String) As Boolean
'判断文件是否存在
Dim fsoSet fso = CreateObject("Scripting.FileSystemObject")
FileExists = fso.FileExists(strPath)
Set fso = NothingEnd Function
Public Sub DeletePictures()
'删除全部图片
'Ctrl+D
Dim Nx As Shape
For Each Nx In Sheet1.Shapes
Nx.Delete
Next
Sheet1.Cells.Clear
Sheet1.Range("A1").Select
End SubPublic Sub SetPicture()
'加载图片
Sheet1.Cells.Clear
Dim Flag As Boolean
Dim R As Integer
Dim Picture As String
Dim PPath As String
R = Sheet2.Range("A65535").End(xlUp).Row
a = 2
b = 1
For i = 2 To R
With Sheet1
PPath = ThisWorkbook.Path + "\" + Sheet2.Cells(i, 1).Value '得到图片路径
If FileExists(PPath) Then 'FileExist函数判断图片是否存在
.Cells(a, b).Select
Picture = .Pictures.Insert(PPath).Name '插入图片
.Cells(a + 13, b).Value = Sheet2.Cells(i, 1).Value '图片名称
.Shapes(Picture).LockAspectRatio = msoFalse '设定图片大小
.Shapes(Picture).Placement = xlMoveAndSize
.Shapes(Picture).Left = .Cells(a, b).Left + 5
.Shapes(Picture).Top = .Cells(a, b).Top + 5
.Shapes(Picture).Height = 205
.Shapes(Picture).Width = 210
'计算图片位置(每行2张,每页3行) If b = 1 Then
b = 6
Else
b = 1
End If
If b = 1 Then
a = a + 14
End If
If a Mod 44 = 0 Then
a = a + 2
End If
End If
End With
send2:
Next Range("A1").Select
End Sub
Public Sub InsertPictures()
'插入图片Call ListAllFiles
Dim Rst As String
Dim cnn As ADODB.Connection
Dim rs As ADODB.Recordset
Set cnn = New ADODB.Connection
With Sheet2
With cnn
.Provider = "microsoft.jet.oledb.4.0"
.ConnectionString = "Extended Properties=Excel 5.0;" + "Data Source=" + ThisWorkbook.FullName
.Open
End With
Set rs = New ADODB.Recordset
Sql = "select distinct 图片名称 From [Sheet2$] where 图片名称 like '%JPG' order by 图片名称"
rs.Open Sql, cnn, adOpenKeyset, adLockBatchOptimistic
.Cells.Clear
Sheet2.Range("A1").Value = "图片名称"
Sheet2.Range("A2").CopyFromRecordset rs
End With
rs.Close
cnn.Close
Set rs = Nothing
Set cnn = NothingCall SetPicture
End Sub 要求所有插入图片与带宏的Excel处於同一个文件夹1.InsertPictures() 插入图片2.DeletePictures()删除图片3.效果图,Excel文件发到你的QQ邮箱,请查收
热心网友
建议手工做个效果并截图上传看看。
