批量插入图片

陈忆群

这是跑团每日跑步打卡的统计表

想请各位老师帮帮忙，用VBA做个程序，实现这个愿望。

1.    电脑文件夹内装有这些照片，同时照片有文件名，也就是网名，照片的格式为jpg和png，文件名有空格、数字、符号、英文、汉字。

2.    批量插入excel表格中，文件名在照片左侧，照片大小3.5X3.cm,单元格随照片大小而变动。

3.    目标单元格由用户输入。

bj917

Attribute VB_Name = "InsertPic"
Sub 插入图片()
'Excel VBA 插入指定图片到单元格并只适应大小
Dim filenames As String
Dim filefilter1 As String
filefilter1 = ("所有图片文件（*.jpg;*.bmp;*.png;*.gif）,*.jpg;*.bmp;*.png;*.gif")    '所有图片文件后面的括号为中文括号
filenames = Application.GetOpenFilename(filefilter1, , "请选择一个图片文件", , MultiSelect:=False)
'没有选中文件时，做容错处理
If filenames = "False" Then
Exit Sub
End If
'插入图片到指定的单元格，Pictures.Insert只插入连接，在其他电脑上无法显示图片；Shapes.AddPicture插入完整图片
Sheet1.Pictures.Insert(filenames).Select
Sheets("签名不合格").Shapes.AddPicture f.Path, 1, 1, ActiveCell.Left + 3, ActiveCell.Top + 3, 0.9 * ActiveCell.Width, 0.9 * ActiveCell.Height
'图片自适应单元格大小
On Error Resume Next
Dim picW As Single, picH As Single
Dim cellW As Single, cellH As Single
Dim rtoW As Single, rtoH As Single
cellW = ActiveCell.Width
cellH = ActiveCell.Height
picW = Selection.ShapeRange.Width
picH = Selection.ShapeRange.Height
rtoW = cellW / picW * 0.95
rtoH = cellH / picH * 0.95
If rtoW < rtoH Then
    Selection.ShapeRange.ScaleWidth rtoW, msoFalse, msoScaleFromTopLeft
Else
    Selection.ShapeRange.ScaleHeight rtoH, msoFalse, msoScaleFromTopLeft
End If
picW = Selection.ShapeRange.Width
picH = Selection.ShapeRange.Height
Selection.ShapeRange.IncrementLeft (cellW - picW) / 2
Selection.ShapeRange.IncrementTop (cellH - picH) / 2
End Sub

Lost_in_Star

选择匹配的单元格，尺寸自行修改即可。
Public Sub Q()

'开始插入图片

    Application.ScreenUpdating = False

Dim PicName$, pand&, k&, PicPath, i, p, n, PicArr, TitleRow

Dim PicNameCol, PicPath2, PicPath3, TPnameCol, TPCol

    PicCol = Selection.Column

    TPCol = PicCol + 1

    TitleRow = 0 'Val(Application.InputBox("请输入标题行的行数。")) '用户设置总表的标题行数

    If TitleRow < 0 Then MsgBox "标题行必须大于等于零，请重新确认? ": Exit Sub

    With Application.FileDialog(msoFileDialogFolderPicker)

        .AllowMultiSelect = False '禁止多选文件夹

       If .Show Then PicPath = .SelectedItems(1) Else: Exit Sub

    End With

    If Right(PicPath, 1) <> "\" Then PicPath = PicPath & "\"

    PicArr = Array(".jpg", ".jpeg", ".bmp", ".png", ".gif")

    For i = TitleRow + 1 To Cells(Rows.Count, PicCol).End(3).Row

        PicPath2 = PicPath

        PicName = Cells(i, PicCol).Value

        If Len(PicName) <> 0 Then

            PicPath3 = PicPath2 & PicName

            pand = 0

            For p = 0 To UBound(PicArr)

               If Len(Dir(PicPath3 & PicArr(p))) Then ' Check if the image file exists in the specified path
    ' Add the picture to the worksheet
    With ActiveSheet.Shapes.AddPicture(PicPath3 & PicArr(p), msoFalse, msoTrue, 100, 100, -1, -1) 'Pictures.Insert(PicPath3 & PicArr(p))
            .Left = Cells(i, TPCol).Left
            .Top = Cells(i, TPCol).Top
            .Width = Cells(i, TPCol).Width
            .Height = Cells(i, TPCol).Height
        End With
   
    pand = 1 ' Set pand to 1 (assuming pand is a variable)

                    n = n + 1

                End If

            Next

            If pand = 0 Then k = k + 1

            End If

    Next

    Application.ScreenUpdating = True

    If k <> 0 Then

        MsgBox "图片插入完成！共有" & k & "张图片未找到，请重新确认源文件! "

    Else

        MsgBox "所有图片插入完成！"

    End If

End Sub

陈忆群

感谢楼上两位老师 多谢