การดึงรูปจาก Drive D

[mr.zatan]

ช่วยแก้ Code VBA ให้หน่อยครับ

- ดึงรูปมาใส่ที่ B2 (โดยอ้างอิงจาก H2) ให้รูปเต็มช่องพอดี
- และที่สำคัญใส่รูปทั้งไฟล์ มีกี่ Sheet ใส่หมด (เพราะตอนนี้ใส่ได้ทีล่ะ Sheet)

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("36994")
    Set ra = .Range("B7", .Range("B65536").End(xlUp).Offset(0, 1))
End With
For Each obj In ActiveSheet.Shapes
    If Left(obj.Name, 7) = "Pict" Then
        obj.Delete
    End If
Next obj
For Each r In ra
    Set imgIcon = ActiveSheet.Shapes.AddPicture( _
    Filename:="D:\image\small_images\" & 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]

Code นั้นเป็นการ Copy มาใช้โดยไม่ได้ปรับเปลียนให้เป็นไปตามที่ต้องการใช้จริง

ช่วยปรับมาก่อน ติดตรงไหนแล้วค่อยถามกันต่อครับ

[mr.zatan]

ปรับไม่เป็นครับ...

[snasui]

ต้องศึกษามาก่อนตามลำดับครับ การใช้ VBA จำเป็นต้องปรับเองเป็นบ้าง ไม่เช่นนั้นแล้วยังไม่ควรใช้ VBA กับงานนี้ครับ

[mr.zatan]

Code นี้พอได้มัย

Sub Picture()
Dim Picname As String

Dim pasteAt As Integer
Dim lThisRow As Long

lThisRow = 2

Do While (Cells(lThisRow, 2) <> "")

Range("b2").Select
pasteAt = Cells(lThisRow, 3)
Cells(pasteAt, 1).Select

Dim Picname As String
Picname = Range("h2")
Picname = Cells(lThisRow, 2)

ActiveSheet.Pictures.Insert("D:\pho\" & Picname & ".jpg").Select
With Selection
.Left = Range("A6").Left
.Top = Range("A6").Top
.Left = Cells(pasteAt, 1).Left
.Top = Cells(pasteAt, 1).Top

.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = 100#
.ShapeRange.Width = 80#
.ShapeRange.Rotation = 0#
End With

lThisRow = lThisRow + 1

Loop

Range("A1").Select
Application.ScreenUpdating = True

Exit Sub

ErrNoPhoto:
MsgBox "Unable to Find Photo"
Exit Sub
Range("B20").Select

End Sub

[snasui]

ลองใช้แล้วให้ผลเป็นอย่างไร ติดขัดบรรทัดไหนหรือไม่ตรงกับที่ต้องการอย่างไรครับ

[mr.zatan]

Option Explicit

Sub ShowPicture()
Dim strPicName As String

strPicName = Range("h2")

With ActiveSheet.Pictures.Insert("D:\image\small_images\" & strPicName & ".jpg")
.Left = Range("b2").Left
.Top = Range("b2").Top
.ShapeRange.LockAspectRatio = msoTrue
.ShapeRange.Height = 103
End With
End Sub

ยังติดตรงที่ว่า เวลาจะใส่รูปผมต้องกด Run ที่ VBA ทุกครั้งเลยเวลาจะใส่รูป

มีวิธีไหนไหม แบบว่า ใส่ชื่อที่ H2 แล้วรูปขึ้นเองเลยที่ B2 โดยไม่ต้องกด Run

แบบว่ากด Enter แล้วขึ้นเลย

[snasui]

กรณีต้องการให้มีผลกับทุกชีท ให้เข้า VBE แล้ว Double Click ที่ ThisWorkbook จากนั้นนำ Code ด้านล่างไปวาง ดูภาพด้านล่างประกอบครับ

Code: Select all

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    If Target.Address(0, 0) = "H2" Then
        Call ShowPicture
    End If
End Sub

[mr.zatan]

ขอบคุณครับ...

แต่เวลารูปไม่มี มันจะ error ครับ

- ถ้ารูปไม่มี ก็ให้ข้ามไปเลยได้มัยครับ...

With ActiveSheet.Pictures.Insert("D:\image\small_images\" & strPicName & ".jpg")

[snasui]

เพิ่ม on error resume next เข้าไปก่อนบรรทัดตามที่โพสต์มาครับ

[mr.zatan]

ขอบคุณครับ