批量导入图片生成缩略图并链接到原图片

dogingate

Sub 单元格尺寸设置(sht, nrowsRng, ncolsRng)
Application.ScreenUpdating = False
On Error Resume Next

For k = 2 To nrowsRng
    If sht.Rows(k).RowHeight <> 60 Then
        sht.Rows(k).RowHeight = 60
    End If
Next k

If sht.Cells(1, tzpslt).EntireColumn.ColumnWidth <> 15 Then
    sht.Cells(1, tzpslt).EntireColumn.ColumnWidth = 15
End If

Application.ScreenUpdating = True

End Sub

Sub 图片批量插入(sht, nrowsRng, ncolsRng, newFolderPath)
Application.ScreenUpdating = False
On Error Resume Next

sht.Select
For Each pic In sht.Shapes '删除表中原来所有的图片
   pic.Delete
Next

Set fso = CreateObject("Scripting.FileSystemObject")
'ARRGS = Split("BMP,RLE,PNG,JPG,", ",") '//可以增加
'picType = "JPG"

For i = 2 To nrowsRng

        sht.Cells(i, tzpslt).Select   '选中这个单元格
        newFilePath = newFolderPath & "\" & Trim(sht.Cells(i, tzpbh))
        If fso.FileExists(newFilePath) = True Then
            sht.Pictures.Insert(newFilePath).Select
            ActiveSheet.Hyperlinks.Add Anchor:=Selection.ShapeRange.Item(1), Address:=newFilePath, ScreenTip:="请点击超链接获取照片"
            With Selection
                .Placement = xlMoveAndSize
                .ShapeRange.LockAspectRatio = msoFalse
                .Top = ActiveCell.Top + 5
                .Left = ActiveCell.Left + 5
                .Height = ActiveCell.Height - 10
                .Width = ActiveCell.Width - 10
            End With
'            Exit For  '//插入后不在寻找文件
        End If

Next i
Application.ScreenUpdating = True
End Sub

slying1112

没有懂，对于刚学习有点难度

chenjx80

slying1112 发表于 2019-5-2 00:57
没有懂，对于刚学习有点难度

批量插入图片（多个典型实例）
http://club.excelhome.net/thread-1474091-1-1.html