遍历文件夹下jpg文件并写入excel并生成超链接

dogingate

Application.ScreenUpdating = False

pth = ThisWorkbook.Path
Set fso = CreateObject("scripting.filesystemobject")
Set wjj = fso.getfolder(pth) '获取文件夹路径

k = 2
For Each wj In wjj.Files '遍历文件夹下所有文件
    extname = Split(wj.Name, ".")(UBound(Split(wj.Name, "."))) '获取文件扩展名
    If UCase(extname) = "JPG" Then
        Cells(k, 16) = wjj.Name
        Cells(k, 17) = wj.Name
        ActiveSheet.Hyperlinks.Add Anchor:=Cells(k, 18), Address:=wj, ScreenTip:="请点击超链接获取照片", TextToDisplay:=wj.Name
        k = k + 1
    End If
Next wj

Application.ScreenUpdating = True

dogingate

Sub getimportfilename(ByVal target As Range)
Dim ff As String
Dim fi As Integer
Dim tt As String
Dim FullPath As Variant
Dim wjname As String
Dim wjj As Object

ff = "图形文件 (*.jpg),*.jpg," & "所有文件 (*.*),*.*"
fi = 1
tt = "请选择文件"

FullPath = Application.GetOpenFilename(filefilter:=ff, FilterIndex:=fi, Title:=tt)

Set fso = CreateObject("scripting.filesystemobject")
'wjname = fso.getfilename(FullPath) '返回给定路径的文件名，含后缀
extname = fso.GetExtensionName(FullPath) '返回给定路径中文件的后缀
wjname = fso.getbasename(FullPath) '返回给定路径的文件名，不含后缀
wjjlj = fso.GetParentFolderName(FullPath) '返回文件所在文件夹的路径

Set wjj = fso.getfolder(wjjlj) '返回文件夹对象
wjjname = wjj.Name '返回文件夹名

'''单元格写数据
Cells(ActiveCell.Row, tzpbh) = wjname
ActiveSheet.Hyperlinks.Add Anchor:=Cells(ActiveCell.Row, tzplj), Address:=FullPath, ScreenTip:="请点击超链接获取照片", TextToDisplay:=wjname
Cells(ActiveCell.Row, tzpwjj) = wjjname


'http://club.excelhome.net/blog-238368-1693.html
End Sub