INSERT รูปภาพจาก Folder เข้ามาใน Excel

[raweeroge]

ต้องการ INSERT รูปภาพจาก Folder เข้ามาใน Excel เพิ่มเติม บริเวณสีน้ำเงินคอลัมภ์ G สามารถดึงภาพมาแสดงได้แล้วโดยอ้างอิงจากคอลัมภ์ F ถ้าผมอยากให้ดึงรูปมาแสดงเพิ่มในคอลัมภ์ K โดยอ้างอิงจากคอลัมภ์ J ไม่ทราบว่า จะต้องแก้ไขหรือเพิ่มเติม CODE อย่างไรครับ

Sub ShowPicture()
Dim r As Range, ra As Range

Book3.xlsm

Dim imgIcon As Object
Dim obj As Object
On Error Resume Next
With Worksheets("Sheet1")
Set ra = .Range("G4", .Range("F65536").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:\Test the end year party card\" & r.Offset(0, -1).Value & ".bmp", LinkToFile:=False, _
SaveWithDocument:=True, Left:=r.Left, Top:=r.Top, _
Width:=r.Width, Height:=r.Height)
Next r
End Sub

[snasui]

ช่วยโพสต์ Code ให้แสดงเป็น Code ดูได้จากกฎการใช้บอร์ดข้อ 5 ด้านบนครับ

[raweeroge]

ขอโทษครับ ขออนุญาตส่ง Code ครับ

Code: Select all

Sub ShowPicture()
    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("G4", .Range("F65536").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:\Test the end year party card\" & r.Offset(0, -1).Value & ".bmp", LinkToFile:=False, _
        SaveWithDocument:=True, Left:=r.Left, Top:=r.Top, _
        Width:=r.Width, Height:=r.Height)
    Next r
End Sub

[snasui]

ตัวอย่างการปรับ Code ครับ

Code: Select all

Sub ShowPicture()
    Dim r As Range, ra As Range, ra1 As Range
    Dim imgIcon As Object
    Dim obj As Object
    On Error Resume Next
    With Worksheets("Sheet1")
        Set ra = .Range("G4", .Range("F65536").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:\Test the end year party card\" & r.Offset(0, -1).Value & ".bmp", LinkToFile:=False, _
        SaveWithDocument:=True, Left:=r.Left, Top:=r.Top, _
        Width:=r.Width, Height:=r.Height)
    Next r
    Set ra1 = ra.Offset(0, 4)
    For Each r In ra1
        Set imgIcon = ActiveSheet.Shapes.AddPicture( _
        Filename:="D:\Test the end year party card\" & r.Offset(0, -1).Value & ".bmp", LinkToFile:=False, _
        SaveWithDocument:=True, Left:=r.Left, Top:=r.Top, _
        Width:=r.Width, Height:=r.Height)
    Next r
End Sub

[raweeroge]

ขอบคุณมากครับ
รบกวนสอบถามเพิ่มเติมครับ คือ ผมต้องการเปลี่ยนชื่อ File พร้อมกันหลายๆ File ใน Folder เดียวกัน (ดูจากตัวอย่างของอาจารย์) แต่ไม่สำเร็จ ขึ้นเตือน Error ว่า Type mismatch รบกวนอาจารย์ช่วยแก้ไขให้ด้วยครับ

Code: Select all

Sub DoSomething()
    Dim rAll As Range
    Dim a As String
    With Sheets("List")
        Set rAll = .Range("A2", .Range("A" & Rows.Count).End(xlUp))
    End With
    For Each r In rAll
         MyPath = r.Value
         MyFile = r.Offset(0, 1).Value
         NewName = r.Offset(0, 2).Value
         If Dir(MyPath & MyFile) <> "" Then
             Name MyPath & MyFile As MyPath & NewName
         End If
     Next r
End Sub

[snasui]

ผมทดสอบแล้วไม่พบปัญหาใด ลองจับภาพ Folder ที่เก็บภาพมาดูกันอีกรอบ จะได้เห็นว่าภาพนามสกุลอะไร กำหนด Path ไว้ถูกต้องหรือไม่ ฯลฯ ครับ

[raweeroge]

ขอบคุณครับมากครับ ภาพนามสกุล .bpm ครับ

Picture1.png

[snasui]

ไฟล์ Excel ที่ส่งมาไม่ได้ระบุ Path ให้ตรงตามภาพที่แนบมาใน Post ล่าสุด หากเป็นตามภาพ Path ควรเป็นตามด้านล่างครับ

D:\scan\test the end year party card

[raweeroge]

ขอบคุณครับ เดี๋ยวกลับมาแจ้งผลครับ