ExcelTip.Net留存知识帖 ---【注:附件之前被网盘供应商清空后,现已修复-现已修复-现已修复为本地下载!】
现在位置:首页 > E问E答 > Excel VBA > 如何从指定文件夹中导入扩展名不同的照片?

如何从指定文件夹中导入扩展名不同的照片?

作者:绿色风 分类: 时间:2022-08-17 浏览:123
楼主
lrlxxqxa
Q:如何从指定文件夹中导入扩展名不同的照片?

A:
  1. Sub insertPic()
  2.     Dim i As Integer
  3.     Dim FilPath As String
  4.     Dim rng As Range
  5.     Dim s As String
  6.     With Sheet1
  7.         For i = 1 To .Range("a65536").End(xlUp).Row
  8.             FilPath = ThisWorkbook.Path & "\学生相片\" & .Cells(i, 1).Text & ".jpg.jpg"
  9.             If Dir(FilPath) <> "" Then
  10. 100:
  11.                 .Pictures.Insert(FilPath).Select
  12.                 Set rng = .Cells(i, 2)
  13.                 With Selection
  14.                     .Top = rng.Top + 1
  15.                     .Left = rng.Left + 1
  16.                     .Width = rng.Width - 1
  17.                     .Height = rng.Height - 1
  18.                 End With
  19.             Else
  20.                 FilPath = ThisWorkbook.Path & "\学生相片\" & .Cells(i, 1).Text & ".jpg.gif"
  21.                 GoTo 100
  22.                 s = s & Chr(10) & .Cells(i, 1).Text
  23.             End If
  24.         Next
  25.         .Cells(1, 1).Select
  26.     End With
  27.     If s <> "" Then
  28.         MsgBox s & Chr(10) & "没有照片!"
  29.     End If
  30. End Sub
  31. Sub DeletePic()
  32.     Dim myShape As Shape
  33.     For Each myShape In Sheet1.Shapes
  34.         If myShape.Type <> 8 Then
  35.             myShape.Delete
  36.         End If
  37.     Next
  38. End Sub


该贴已经同步到

相片导入lr.rar
2楼
lrlxxqxa
谢谢莫莫的完善


相片的格式不统一,同时由于隐藏后缀名,有些是gif,有些是jpg,还有可能有考虑不到的格式图片出现,将代码改成模糊匹配图片格式

  1. Sub insertPic()
  2.     Dim i As Integer
  3.     Dim FilPath As String
  4.     Dim rng As Range
  5.     Dim s As String
  6.     With Sheet1
  7.         For i = 1 To .Range("a65536").End(xlUp).Row
  8.             FilPath = ThisWorkbook.Path & "\学生相片\" & .Cells(i, 1).Text & ".jpg.jpg"
  9.             If Dir(FilPath) <> "" Then
  10. 100:
  11.                 .Pictures.Insert(FilPath).Select
  12.                 Set rng = .Cells(i, 2)
  13.                 With Selection
  14.                     .Top = rng.Top + 1
  15.                     .Left = rng.Left + 1
  16.                     .Width = rng.Width - 1
  17.                     .Height = rng.Height - 1
  18.                 End With
  19.             Else
  20.                 FilPath = ThisWorkbook.Path & "\学生相片\" & .Cells(i, 1).Text & ".jpg.gif"
  21.                 GoTo 100
  22.                 s = s & Chr(10) & .Cells(i, 1).Text
  23.             End If
  24.         Next
  25.         .Cells(1, 1).Select
  26.     End With
  27.     If s <> "" Then
  28.         MsgBox s & Chr(10) & "没有照片!"
  29.     End If
  30. End Sub
  31. Sub DeletePic()
  32.     Dim myShape As Shape
  33.     For Each myShape In Sheet1.Shapes
  34.         If myShape.Type <> 8 Then
  35.             myShape.Delete
  36.         End If
  37.     Next
  38. End Sub



相片导入(小莫修改版).rar

免责声明

有感于原ExcelTip.Net留存知识的价值及部分知识具有的时间限定性因素, 经与ExcelTip.Net站长Apolloh商议并征得其同意, 现将原属ExcelTip.Net的知识帖采集资料于本站点进行展示, 供有需要的人士查询使用,也慰缅曾经的论坛时代。 所示各个帖子的原作者如对版权有异议, 可与本人沟通提出,或于本站点留言,我们会尽快处理。 在此,感谢ExcelTip.Net站长Apolloh的支持,感谢本站点所有人**绿色风(QQ:79664738)**的支持与奉献,特此鸣谢!
------本人网名**KevinChengCW(QQ:1210618015)**原ExcelTip.Net总版主之一

评论列表
sitemap