รบกวนเพื่อนๆสมาชิคช่วยหน่อยครับ เรื่องการ แทรกรูป โดยใช้ Macro
Posted: Sun Jul 16, 2017 8:31 am
เนื่องจากผมได้เจอโค้ดของ (ขออนุญาต อ้างชื่อนะครับ) อาจารย์ snasui แล้ว นำมาทดลองใช้จึงเกิดความคิดอย่ากศึกษาเพื่อนำไปใช้จริง แต่ไม่ง่ายเลยสำหรับผมที่ไม่ค่อยมีพื้นฐานทางนี้จึงอยากจะขอรบกวนสมาชิคช่วย ตรวจสอบ แนะนำ แก้ใข ให้ผมหน่อยครับ
(ปัจจุบันผมใช้ Excel 2010 อยู่ครับ)
โดยผลลัพท์ที่อยากได้นั้นคือ
1. เมื่อกดปุ่มที่สร้างไว้แล้ว อยากให้รูป มีขนาดเท่ากัน เซลที่ผสานไว้ หรือ สามารถกำหนดขนาดได้ครับ
2. อยากให้ ดึงรูป ตามชื่อ Folder ที่เซล A2 และ A3 แล้ว เซฟไฟล์ใหม่ ไว้มาตามชื่อของแต่ละ Folder ที่ตั้งไว้ครับ
ทั้งนี้ผมได้แนบไฟล์ที่ผมทดลองทำมาแล้วพร้อมทั้ง Folder รูปภาพครับ ผิดพลาดประการไดขออภัยมา ณ ที่นี้ด้วยครับ ขอบคุณครับ
Code ที่ผมนำมาใช้อยู่นะครับ
(ปัจจุบันผมใช้ Excel 2010 อยู่ครับ)
โดยผลลัพท์ที่อยากได้นั้นคือ
1. เมื่อกดปุ่มที่สร้างไว้แล้ว อยากให้รูป มีขนาดเท่ากัน เซลที่ผสานไว้ หรือ สามารถกำหนดขนาดได้ครับ
2. อยากให้ ดึงรูป ตามชื่อ Folder ที่เซล A2 และ A3 แล้ว เซฟไฟล์ใหม่ ไว้มาตามชื่อของแต่ละ Folder ที่ตั้งไว้ครับ
ทั้งนี้ผมได้แนบไฟล์ที่ผมทดลองทำมาแล้วพร้อมทั้ง Folder รูปภาพครับ ผิดพลาดประการไดขออภัยมา ณ ที่นี้ด้วยครับ ขอบคุณครับ
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("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