Page 1 of 1
การดึงรูปจาก Drive D
Posted: Thu Jan 29, 2015 6:10 pm
by 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
Re: การดึงรูปจาก Drive D
Posted: Thu Jan 29, 2015 6:22 pm
by snasui
Code นั้นเป็นการ Copy มาใช้โดยไม่ได้ปรับเปลียนให้เป็นไปตามที่ต้องการใช้จริง
ช่วยปรับมาก่อน ติดตรงไหนแล้วค่อยถามกันต่อครับ
Re: การดึงรูปจาก Drive D
Posted: Thu Jan 29, 2015 6:34 pm
by mr.zatan
ปรับไม่เป็นครับ...
Re: การดึงรูปจาก Drive D
Posted: Thu Jan 29, 2015 6:39 pm
by snasui
ต้องศึกษามาก่อนตามลำดับครับ การใช้ VBA จำเป็นต้องปรับเองเป็นบ้าง ไม่เช่นนั้นแล้วยังไม่ควรใช้ VBA กับงานนี้ครับ
Re: การดึงรูปจาก Drive D
Posted: Thu Jan 29, 2015 10:14 pm
by 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
Re: การดึงรูปจาก Drive D
Posted: Thu Jan 29, 2015 10:23 pm
by snasui
ลองใช้แล้วให้ผลเป็นอย่างไร ติดขัดบรรทัดไหนหรือไม่ตรงกับที่ต้องการอย่างไรครับ
Re: การดึงรูปจาก Drive D
Posted: Fri Jan 30, 2015 1:14 pm
by 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 แล้วขึ้นเลย
Re: การดึงรูปจาก Drive D
Posted: Fri Jan 30, 2015 1:26 pm
by 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
Re: การดึงรูปจาก Drive D
Posted: Fri Jan 30, 2015 3:37 pm
by mr.zatan
ขอบคุณครับ...
แต่เวลารูปไม่มี มันจะ error ครับ
- ถ้ารูปไม่มี ก็ให้ข้ามไปเลยได้มัยครับ...
With ActiveSheet.Pictures.Insert("D:\image\small_images\" & strPicName & ".jpg")
Re: การดึงรูปจาก Drive D
Posted: Fri Jan 30, 2015 4:55 pm
by snasui
เพิ่ม
on error resume next เข้าไปก่อนบรรทัดตามที่โพสต์มาครับ
Re: การดึงรูปจาก Drive D
Posted: Fri Jan 30, 2015 5:32 pm
by mr.zatan
ขอบคุณครับ