Snasui Excel Forum

:D Code นั้นเป็นการนำมาใช้ตามแบบต้นฉบับ ได้ปรับแค่ตำแหน่งที่วางข้อมูล ยังไม่มีส่วนของการ Save ไฟล์ตามที่เขียนแจ้งมาแต่อย่างใด ช่วยเขียนเพิ่มเติมสำหรับส่วนนี้มาด้วย หรือหากเขียนมาแล้วช่วยแจ้งว่าอยู่ที่ Procedure ใด ติดขัดบรรทัดไหน อย่างไร จะได้ตอบต่อไปจากนั้นครับ

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("C1", .Range("B65536").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:="C:\A\" & 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

เนื่องจากผมได้เจอโค้ดของ (ขออนุญาต อ้างชื่อนะครับ) อาจารย์ snasui แล้ว นำมาทดลองใช้จึงเกิดความคิดอย่ากศึกษาเพื่อนำไปใช้จริง แต่ไม่ง่ายเลยสำหรับผมที่ไม่ค่อยมีพื้นฐานทางนี้จึงอยากจะขอรบกวนสมาชิคช่วย ตรวจสอบ แนะนำ แก้ใข ให้ผมหน่อยครับ
(ปัจจุบันผมใช้ Excel 2010 อยู่ครับ)

โดยผลลัพท์ที่อยากได้นั้นคือ
1. เมื่อกดปุ่มที่สร้างไว้แล้ว อยากให้รูป มีขนาดเท่ากัน เซลที่ผสานไว้ หรือ สามารถกำหนดขนาดได้ครับ
2. อยากให้ ดึงรูป ตามชื่อ Folder ที่เซล A2 และ A3 แล้ว เซฟไฟล์ใหม่ ไว้มาตามชื่อของแต่ละ Folder ที่ตั้งไว้ครับ

ทั้งนี้ผมได้แนบไฟล์ที่ผมทดลองทำมาแล้วพร้อมทั้ง Folder รูปภาพครับ ผิดพลาดประการไดขออภัยมา ณ ที่นี้ด้วยครับ ขอบคุณครับ :D

Code ที่ผมนำมาใช้อยู่นะครับ

[code]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("C1", .Range("B65536").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:="C:\A\" & 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]