非常實用(查詢圖片)請幫忙解決(問題以解決謝謝幫忙)

joyark

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
With Target.Cells(1)
    If (.Column = 3 Or .Column = 7) And .Row Mod 16 = 2 Then
        addPic Target.Cells(1)
    End If
End With
End Sub

Option Explicit
Sub fdjpg(nm As String)
With Application.FileSearch
    .LookIn = ThisWorkbook.Path
    .SearchSubFolders = True
    .Filename = nm & ".jpg"
    If .Execute <> 0 Then
        nm = .FoundFiles(1)
    Else
        nm = ""
    End If
End With
End Sub
Sub addPic(tgRng As Range)
Dim rng As Range
Dim nm As String
Dim shp As Shape
With tgRng
    nm = .Text
    Set rng = .Offset(0, -2).Resize(15, 1)
End With
    fdjpg nm
If nm <> "" Then
    rng.Worksheet.Pictures.Insert(nm).Select
    With Selection
        .Top = rng.Top
        .Left = rng.Left
        .Placement = xlMoveAndSize
        .Width = rng.Width
        .Height = rng.Height
    End With
Else
    MsgBox nm & " not found!"
End If
End Sub

問題以解決謝謝幫忙

修改如下:

Option Explicit
Sub fdjpg(nm As String)
With Application.FileSearch
    .LookIn = ThisWorkbook.Path
    .SearchSubFolders = True
    .Filename = nm & ".jpg"
    If .Execute <> 0 Then
        nm = .FoundFiles(1)
    Else
        nm = ""
    End If
End With
End Sub
Sub addPic(tgRng As Range)
Dim rng As Range
Dim nm As String
Dim shp As Shape
Dim picname As String
Dim pic As Shape
picname = tgRng.Row & tgRng.Column
With tgRng
    nm = .Text
    Set rng = .Offset(0, -2).Resize(15, 1)
End With
    fdjpg nm
If nm <> "" Then
For Each pic In rng.Worksheet.Shapes
If pic.Name = picname Then pic.Delete
Next
  Set shp = rng.Worksheet.Shapes.AddPicture(nm, msoFalse, msoTrue, rng.Left, rng.Top, rng.Width, rng.Height)
  shp.Name = picname
Else
    MsgBox nm & " 您可能填错了货号。"
End If
End Sub

[此贴子已经被作者于2005-4-13 1:31:12编辑过]