Snasui Excel Forum

Code: Select all

Public Sub san()
Dim r As Range, obj As Object
Dim fs As Object, i As Integer
Dim Img1 As Variant, Img2 As Variant

Set r = Worksheets("302").Range("F1")
Set fs = Application.FileSearch

On Error Resume Next

For Each obj In ActiveSheet.Shapes
    If Left(obj.Name, 3) = "Pic" Then
            obj.Delete
    End If
Next

    With fs
        .LookIn = "D:\pic\" & r '
        .SearchSubFolders = True
        .Filename = "*"
        If .Execute() > 0 Then
            With Range("A3")
                Set Img1 = ActiveSheet.Shapes.AddPicture( _
                Filename:="D:\pic\111" & r.Offset(0, -1).Value & ".jpg", LinkToFile:=False, _
                SaveWithDocument:=True, Left:=.Left, Top:=.Top, _
                Width:=250, Height:=250)
            End With
            With Range("F3")
                Set Img2 = ActiveSheet.Shapes.AddPicture( _
                Filename:="D:\pic\map" & r.Offset(0, -1).Value & ".jpg", LinkToFile:=False, _
                SaveWithDocument:=True, Left:=.Left, Top:=.Top, _
                Width:=250, Height:=250)
            End With
        Else
            MsgBox "There were no files found."
            Exit Sub
        End If
    End With
    
End Sub

Code: Select all

Public Sub picshow()
Dim r As Range, ra As Range
    Dim imgIcon As Object
    Dim obj As Object
    On Error Resume Next
    With Worksheets("Sheet1")
        Set ra = .Range("d2", .Range("c2").End(xlUp).Offset(0, 1))
    End With
    For Each obj In ActiveSheet.Shapes
        If Left(obj.Name, 4) = "Pict" Then
            obj.Delete
        End If
    Next obj
    For Each r In ra
        Set imgIcon = ActiveSheet.Shapes.AddPicture( _
        Filename:="D:\pic\map\" & r.Offset(0, -1).Value & ".jpg", LinkToFile:=False, _
        SaveWithDocument:=True, Left:=r.Left, Top:=r.Top, _
        Width:=r.Width, Height:=r.Height)
    Next r
End Sub

Code: Select all

Public Sub picshow()
Dim r As Range, ra As Range
    Dim imgIcon As Object
    Dim obj As Object
    On Error Resume Next
'    With Worksheets("Sheet1")
'        Set ra = .Range("d2", .Range("c2").End(xlUp).Offset(0, 1))
'    End With
    For Each obj In ActiveSheet.Shapes
        If Left(obj.Name, 4) = "Pict" Then
            obj.Delete
        End If
    Next obj
'    For Each r In ra
        Set imgIcon = ActiveSheet.Shapes.AddPicture( _
        Filename:="D:\pic\map\" & Range("C2").Value & ".jpg", LinkToFile:=False, _
        SaveWithDocument:=True, Left:=Range("D2").Left, Top:=Range("D2").Top, _
        Width:=Range("D2").Width, Height:=Range("D2").Height)
        Set imgIcon = ActiveSheet.Shapes.AddPicture( _
        Filename:="D:\pic\111\" & Range("C2").Value & ".jpg", LinkToFile:=False, _
        SaveWithDocument:=True, Left:=Range("H2").Left, Top:=Range("H2").Top, _
        Width:=Range("H2").Width, Height:=Range("H2").Height)
'    Next r
End Sub

Code: Select all

Public Sub picshow()
Dim r As Range, ra As Range
    Dim imgIcon As Object
    Dim obj As Object
    On Error Resume Next
'    With Worksheets("302")
'        Set ra = .Range("c116", .Range("b116").End(xlUp).Offset(0, 1))
'    End With
    For Each obj In ActiveSheet.Shapes
        If Left(obj.Name, 4) = "Pict" Then
            obj.Delete
        End If
    Next obj
'    For Each r In ra
        Set imgIcon = ActiveSheet.Shapes.AddPicture( _
        Filename:="D:\302\map\" & Range("b116").Value & ".jpg", LinkToFile:=False, _
        SaveWithDocument:=True, Left:=Range("c116").Left, Top:=Range("c116").Top, _
        Width:=250, Height:=250)
        Set imgIcon = ActiveSheet.Shapes.AddPicture( _
        Filename:="D:\302\pic1\" & Range("b116").Value & ".jpg", LinkToFile:=False, _
        SaveWithDocument:=True, Left:=Range("n116").Left, Top:=Range("n116").Top, _
        Width:=250, Height:=250)
'    Next r
End Sub

Code: Select all

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address = "$T$3" Then
        Call picshow
    End If
End Sub