VBA遍历文件夹中的图像并找到相似的匹配项

时间:2019-07-11 14:38:38

标签: vba

我有一个包含很多产品图片的文件夹。每个产品都有多个图像。我需要标识以我的产品编号开头(例如100100)并以两个结尾“ _FRONT”或“ _ALTERNATE”之一结尾的字母。两者之间还有其他信息。例如,文件名可以是100100_headset_FRONT或100100_headset_SIDE。我希望它找到每个产品的正面或替代图像。

我已经成功地提取了图像,我想我已经接近命名文件的方式了,但是还不足够。代码返回错误“找不到指定的文件”

Sub PictureP()
Dim picname As String, picend As String
Dim PicPath As String
Dim lThisRow As Long
Dim Pic As Shape
Dim rngPic As Range


lThisRow = 3

Do While (Cells(lThisRow, 2) <> "")

    Set rngPic = Cells(lThisRow, 1) 'This is where picture will be inserted

    picname = Cells(lThisRow, 2) 'This is the picture name
    picend = "_FRONT"

    present = Dir("H:\Media\Images\1 Web Ready\Previews\" & picname & "*" & picend & ".jpg")
    PicPath = ("H:\Media\Images\1 Web Ready\Previews\" & picname & "*" & picend & ".jpg")


If present <> "" Then

      Set Pic = ActiveSheet.Shapes.AddPicture(PicPath, msoFalse, msoCTrue, 1, 1, -1, -1)

    Else

    Cells(lThisRow, 1) = ""

    End If

lThisRow = lThisRow + 1
Loop

Range("B3").Select
On Error GoTo 0
Application.ScreenUpdating = True

Exit Sub

End Sub

代码返回错误“找不到指定的文件”

1 个答案:

答案 0 :(得分:1)

Dir()正在正确评估*通配符,并返回匹配的FIRST值。

PicPath =正在设置字符串值。设置字符串值并不关心通配符,因此会将其作为文字值添加。

如果您在运行时调试并打印出两个值,则会在PicPath中看到*

最简单的解决方案是仅更改picPath以使用Dirpresent的结果,并将其附加到Dir()搜索的目录中。

请参阅下文。

Sub PictureP()
Dim picname As String, picend As String
Dim PicPath As String
Dim lThisRow As Long
Dim Pic As Shape
Dim rngPic As Range


lThisRow = 3

Do While (Cells(lThisRow, 2) <> "")

    Set rngPic = Cells(lThisRow, 1) 'This is where picture will be inserted

    picname = Cells(lThisRow, 2) 'This is the picture name
    picend = "_FRONT"

    present = Dir("H:\Media\Images\1 Web Ready\Previews\" & picname & "*" & picend & ".jpg")
    PicPath = ("H:\Media\Images\1 Web Ready\Previews\" & present)


If present <> "" Then

      Set Pic = ActiveSheet.Shapes.AddPicture(PicPath, msoFalse, msoCTrue, 1, 1, -1, -1)

    Else

    Cells(lThisRow, 1) = ""

    End If

lThisRow = lThisRow + 1
Loop

Range("B3").Select
On Error GoTo 0
Application.ScreenUpdating = True

Exit Sub

End Sub