作者:绿色风
分类:
时间:2022-08-17
浏览:123
楼主 lrlxxqxa |
Q:如何从指定文件夹中导入扩展名不同的照片?
A:
- Sub insertPic()
- Dim i As Integer
- Dim FilPath As String
- Dim rng As Range
- Dim s As String
- With Sheet1
- For i = 1 To .Range("a65536").End(xlUp).Row
- FilPath = ThisWorkbook.Path & "\学生相片\" & .Cells(i, 1).Text & ".jpg.jpg"
- If Dir(FilPath) <> "" Then
- 100:
- .Pictures.Insert(FilPath).Select
- Set rng = .Cells(i, 2)
- With Selection
- .Top = rng.Top + 1
- .Left = rng.Left + 1
- .Width = rng.Width - 1
- .Height = rng.Height - 1
- End With
- Else
- FilPath = ThisWorkbook.Path & "\学生相片\" & .Cells(i, 1).Text & ".jpg.gif"
- GoTo 100
- s = s & Chr(10) & .Cells(i, 1).Text
- End If
- Next
- .Cells(1, 1).Select
- End With
- If s <> "" Then
- MsgBox s & Chr(10) & "没有照片!"
- End If
- End Sub
- Sub DeletePic()
- Dim myShape As Shape
- For Each myShape In Sheet1.Shapes
- If myShape.Type <> 8 Then
- myShape.Delete
- End If
- Next
- End Sub
该贴已经同步到 相片导入lr.rar |
2楼 lrlxxqxa |
谢谢莫莫的完善 相片的格式不统一,同时由于隐藏后缀名,有些是gif,有些是jpg,还有可能有考虑不到的格式图片出现,将代码改成模糊匹配图片格式
- Sub insertPic()
- Dim i As Integer
- Dim FilPath As String
- Dim rng As Range
- Dim s As String
- With Sheet1
- For i = 1 To .Range("a65536").End(xlUp).Row
- FilPath = ThisWorkbook.Path & "\学生相片\" & .Cells(i, 1).Text & ".jpg.jpg"
- If Dir(FilPath) <> "" Then
- 100:
- .Pictures.Insert(FilPath).Select
- Set rng = .Cells(i, 2)
- With Selection
- .Top = rng.Top + 1
- .Left = rng.Left + 1
- .Width = rng.Width - 1
- .Height = rng.Height - 1
- End With
- Else
- FilPath = ThisWorkbook.Path & "\学生相片\" & .Cells(i, 1).Text & ".jpg.gif"
- GoTo 100
- s = s & Chr(10) & .Cells(i, 1).Text
- End If
- Next
- .Cells(1, 1).Select
- End With
- If s <> "" Then
- MsgBox s & Chr(10) & "没有照片!"
- End If
- End Sub
- Sub DeletePic()
- Dim myShape As Shape
- For Each myShape In Sheet1.Shapes
- If myShape.Type <> 8 Then
- myShape.Delete
- End If
- Next
- End Sub
相片导入(小莫修改版).rar |
免责声明
有感于原ExcelTip.Net留存知识的价值及部分知识具有的时间限定性因素,
经与ExcelTip.Net站长Apolloh商议并征得其同意,
现将原属ExcelTip.Net的知识帖采集资料于本站点进行展示,
供有需要的人士查询使用,也慰缅曾经的论坛时代。
所示各个帖子的原作者如对版权有异议,
可与本人沟通提出,或于本站点留言,我们会尽快处理。
在此,感谢ExcelTip.Net站长Apolloh的支持,感谢本站点所有人**绿色风(QQ:79664738)**的支持与奉献,特此鸣谢!
------本人网名**KevinChengCW(QQ:1210618015)**原ExcelTip.Net总版主之一