Excel Forum

Code: Select all

Sub ShowPicture1()
    Dim r1 As Range, ra1 As Range
    Dim imgIcon1 As Object
    Dim obj1 As Object
    On Error Resume Next
    With Worksheets("1")
        Set ra1 = .Range("C15", .Range("F65536").End(xlUp).Offset(0, 1))
    End With
    For Each obj1 In ActiveSheet.Shapes
            If Left(obj1.Name, 1) = "Pict" Then
            obj1.Delete
        End If
    Next obj1
    For Each r1 In ra1
        Set imgIcon1 = ActiveSheet.Shapes.AddPicture( _
        Filename:="D:\testvba\" & r1.Offset(0, -1).Value & "-1.jpg", LinkToFile:=False, _
        SaveWithDocument:=True, Left:=r1.Left, Top:=r1.Top, _
        Width:=r1.Width, Height:=r1.Height)
    Next r1
    
End Sub

Sub ShowPicture2()
    Dim r2 As Range, ra2 As Range
    Dim imgIcon2 As Object
    Dim obj2 As Object
    On Error Resume Next
    With Worksheets("1")
        Set ra2 = .Range("J16", .Range("F65536").End(xlUp).Offset(0, 1))
    End With
    For Each obj2 In ActiveSheet.Shapes
            If Left(obj2.Name, 1) = "Pict" Then
            obj2.Delete
        End If
    Next obj2
    For Each r2 In ra2
        Set imgIcon2 = ActiveSheet.Shapes.AddPicture( _
        Filename:="D:\testvba\" & r2.Offset(0, -1).Value & "-2.jpg", LinkToFile:=False, _
        SaveWithDocument:=True, Left:=r2.Left, Top:=r2.Top, _
        Width:=r2.Width, Height:=r2.Height)
    Next r2
   
End Sub
Sub ShowPicture3()
    Dim r3 As Range, ra3 As Range
    Dim imgIcon3 As Object
    Dim obj3 As Object
    On Error Resume Next
    With Worksheets("1")
        Set ra3 = .Range("I18", .Range("F65536").End(xlUp).Offset(0, 1))
    End With
    For Each obj3 In ActiveSheet.Shapes
            If Left(obj3.Name, 1) = "Pict" Then
            obj3.Delete
        End If
    Next obj3
    For Each r3 In ra3
        Set imgIcon3 = ActiveSheet.Shapes.AddPicture( _
        Filename:="D:\testvba\" & r3.Offset(0, -1).Value & "-3.jpg", LinkToFile:=False, _
        SaveWithDocument:=True, Left:=r3.Left, Top:=r3.Top, _
        Width:=r3.Width, Height:=r3.Height)
    Next r3
End Sub

Code: Select all

Public Sub delshapes()
    Dim ojb As Object
    For Each ojb In ActiveSheet.Shapes
        If InStr(ojb.Name, "รูป") + InStr(ojb.Name, "Pic") > 0 Then _
            ojb.Delete
    Next ojb
End Sub

Code: Select all

Sub ShowPicture1()
    Dim r1 As Range, i As Integer, ButName As String
    Dim imgIcon1 As Object
    Dim obj As Object
    ButName = Application.Caller
    i = Val(Mid(ButName, InStr(1, ButName, " ")))
    Select Case i
        Case Is = 1: Set r1 = Range("c15")
        Case Is = 2: Set r1 = Range("j16")
        Case Is = 3: Set r1 = Range("i18")
    End Select
    For Each obj In ActiveSheet.Shapes
        If obj.Left = r1.Left Then _
            obj.Delete
    Next obj
    Set imgIcon1 = ActiveSheet.Shapes.AddPicture( _
        Filename:="D:\testvba\" & r1.Offset(, -1) & "_" & i & ".jpg", _
        linktofile:=False, savewithdocument:=True, Left:=r1.Left, _
        Top:=r1.Top, Width:=r1.MergeArea.Width, Height:=r1.MergeArea.Height)
End Sub

Code: Select all

If obj.Left = r1.Left Then

Code: Select all

Public Sub delshapes()
    Dim ojb As Object
    For Each ojb In ActiveSheet.Shapes
        If InStr(ojb.Name, "รูป") + InStr(ojb.Name, "Pic") > 0 Then _
            ojb.Delete
    Next ojb
End Sub

Code: Select all

Public Sub delshapes()
    Dim ojb As Object
    For Each ojb In ActiveSheet.Shapes
		if ojb.Name <> "logoCompany" then
			If InStr(ojb.Name, "รูป") + InStr(ojb.Name, "Pic") > 0 Then _
				ojb.Delete
		end if
    Next ojb
End Sub