VBA ShowPicture แบบหลายรูปภาพ

[zixnutz]

สวัสดีครับ ผมขอออกตัวก่อนนะครับ ว่าหัดทำ VBA ครั้งแรก
ผมต้องการที่จะแสดงรูปภาพ แล้วผมก็ลองค้นหาได้เจอแนวๆการทำจากเวปบล๊อคของทางเวปพอดี
อนุญาติแนบ Link นะครับ เห็นว่าเป็นเจ้าของเวปเดียวกัน
http://snasui.blogspot.com/2011/05/folder-excel.html

แต่ผมต้องการมากกว่าที่เวปแสดงให้ครับ คือ
1. ต้องการให้แสดงภาพ 3 ภาพ โดยใช้ชื่อการหาเดียวกัน ซึ่งผมได้ลองทำแล้ว แต่ต้องทำการแยกปุ่มกดแสดง
แต่เวลากดปุ่มแสดงภาพ Picture 1 แต่รูปไม่แสดงภาพ 1 ช่องเดียว แต่กลับแสดงภาพ 1 ถึง 3 ช่อง
ซึ่งผมต้องการจริงๆคือ ต้องการใช้แค่ปุ่มเดียว แต่แสดงทีเดียว 3 ภาพ แต่ผมไม่ทราบว่า จะต่อสูตรอย่างไร แทรกอยู่ส่วนไหนของสูตร

2. ผมเจอปัญหาภาพไม่แสดงทั้งเซลล์ที่ผสานครับ แสดงแค่ cell นั้นๆ

3. ผมอยากทราบจุดที่สูตรจะใช้ในการหาครับ ผมหาไม่เจอ คือผมต้องการให้หาข้อมูลจาก cell M10 ที่ลองแก้ไขดูจากสูตรที่มีในเวปคือ หาข้อมูลจาก เซลล์ด้านซ้าย ถ้ากรอกเป็นพิกัดเซลล์ต้องทำอย่างไรครับ

สูตรที่เขียนครับ

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

อาจจะยาวบ้าง เพราะเพิ่งหัดทำครับ ผิดตรงไหน หรือเขียนแบบไหนง่ายกว่า รบกวนช่วยชี้แนะด้วยครับ
ขอบคุณครับ

[DhitiBank]

หากกดทีละปุ่มเพื่อใส่รูปทีละรูป ผมคิดว่าเขียนเพียงคำสั่งเดียวแล้วให้ทุกปุ่มรันจากคำสั่งเดียวกันก็ได้ครับ แต่ชื่อปุ่มควรให้สัมพันธ์กันครับ ทำได้ดังนี้

1. ก่อนอื่น ลบรูปที่ได้ใส่เอาไว้ก่อนหน้านี้ออกก่อนครับ มีเยอะหลายร้อยรูปซึ่งทำให้โค้ดรันช้าและขนาดไฟล์ใหญ่มากครับ

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

วางโค้ดด้านบนนี้ไว้ที่โมดูลไหนก็ได้ แล้วก็เลือกชีท "1" แล้วรันโค้ดนี้ครับ

2. เปลี่ยนชื่อปุ่มในชีท "1" ใหม่ ให้เรียงลำดับอย่างถูกต้องครับ เช่น สี่เหลี่ยมผืนผ้ามุมมน 1, สี่เหลี่ยมผืนผ้ามุมมน 2, สี่เหลี่ยมผืนผ้ามุมมน 3,...

3. ลองปรับโค้ดใน ShowPicture1() เป็นแบบนี้ครับ

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

4. ตั้งค่าให้ปุ่มทั้ง 3 รันคำสั่ง ShowPicture1() ครับ

[zixnutz]

ขึ้น Error ว่า
Run-Time error '91':
Object variable or With variable not set
ตรงสูตรนี้ครับ

Code: Select all

If obj.Left = r1.Left Then

คือติดปัญหาอะไรหรอครับ ไม่ทราบว่าเกี่ยวกับชื่อปุ่มหรือเปล่าครับ รบกวนด้วยครับ

[DhitiBank]

ขออภัยครับ ผมอธิบายการเปลี่ยนชื่อปุ่มไม่ชัดเจน การเปลี่ยนชื่อปุ่มไม่ได้หมายถึงการเปลี่ยนข้อความที่ปรากฏบนปุ่มหรือวัตถุใดๆ ครับ แต่เป็นการเปลี่ยนชื่อตามรูปด้านล่างครับ

2016-11-15 13_01_34-Calculator.png

เอาเม้าส์คลิกที่ปุ่ม แล้วไปที่ Name box ครับ เปลี่ยนชื่อให้สอดคล้องกับลำดับของปุ่ม

2016-11-15 13_01_57-Calculator.png

[zixnutz]

ได้ตามต้องการเลยครับ

ขอสอบถามเพิ่มเติมหน่อยครับ
คือสูตรการลบรูปที่ให้มา สูตรนี้ ผมได้ทำปุ่มสำหรับการ Clear ภาพ

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

แต่สูตรดันไปลบรูปภาพตราบริษัทที่ต้องแทรกไว้บนหัวกระดาษด้วยครับ ไม่ทราบว่ามีวิธีใดในการไม่ให้ภาพตราถูกลบด้วยไหมครับ ขอรบกวนอีกสักนิดครับ ขอบคุณครับ

[DhitiBank]

สมมติว่าโลโก้ชื่อ logoCompany นะครับ

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

[zixnutz]

ขอบคุณครับ ได้ตามที่ต้องการเลยครับ