รบกวนช่วยดูข้อมูลในการดึงภาพ โดยการเขียน VB ครับ

[dal252244]

ผมต้องการดึงรูปภาพจากโฟลเดอร์มาแสดง โดยภาพจะอยู่ในสองโฟลเดอร์ ซึ่งใช้ชื่อภาพเหมือนกันครับ ผมทดลองตาม VB ที่อาจารย์ลงไว้แต่ก็ทำไม่ได้ครับ

[snasui]

ทดลองตาม Link ไหนครับ

Code ควรแนบมาในไฟล์และไฟล์ควรจะมีนามสกุลเป็น .xlsm เพื่อที่จะแนบ Code ได้ครับ ในการใช้งาน VBA ให้อ่านตามกฎข้อ 5 ด้านบนประกอบครับ

[dal252244]

ฺVB ที่ผมเขียนตามนี้ครับ แต่มันจะดึงได้แ่ค่รูปเดียวครับ และมันไม่อัตโนมัติครับ ผมต้องสร้างปุ่มให้กดอีกครั้งเพื่อให้รูปขึ้น แต่อยากให้มันขึ้นรูปอัตโนมัติครับ ขอบคุณอาจารย์ด้วยนะครับ ที่ตอบกระทู้

[dal252244]

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("A3", .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:\pic\map\" & r.Offset(0, -1).Value & ".jpg", LinkToFile:=False, _
SaveWithDocument:=True, Left:=r.Left, Top:=r.Top, _
Width:=500, Height:=500)
Next r
End Sub

[snasui]

อ่านซ้ำอีกครั้งหนึ่งครับ

Code ควรแนบมาในไฟล์และไฟล์ควรจะมีนามสกุลเป็น .xlsm เพื่อที่จะแนบ Code ได้ครับ

สำหรับการปรับ Code ให้เป็น Code ในกล่องความเห็นนี้ดูที่นี่ครับ viewtopic.php?f=3&t=1187

และสำหรับการแสดงหลายภาพตาม Code ที่ Copy มานั้น เป็นการแสดงภาพโดยระบุชื่อภาพไว้ในเซลล์ จากนั้นใช้ Code เข้าไปอ่านว่าชื่อภาพในเซลล์คือชื่อใดเพื่อจะนำภาพนั้นมาแสดง โดยเขียน Path ของตำแหน่งภาพในไว้ใน Code ครับ ลองดูต้นแหล่งที่ไป Copy Code มาครับว่าลักษณะการวางข้อมูลตัวอย่างที่ผมเขียนไว้เป็นแบบใด ก่อนที่จะประยุกต์ไปเป็นแบบอื่น ให้ทำตามตัวอย่างให้ได้ก่อนครับ

[dal252244]

ผมลองทำ vba ตามนี้แล้วคับ พอกด run มันขึ้น error ตามภาพคับ

Code: Select all

Public Sub san()
Dim r As Range, obj As Object
Dim fs As Object, i As Integer
Dim Img1 As Variant, Img2 As Variant

Set r = Worksheets("302").Range("F1")
Set fs = Application.FileSearch

On Error Resume Next

For Each obj In ActiveSheet.Shapes
    If Left(obj.Name, 3) = "Pic" Then
            obj.Delete
    End If
Next

    With fs
        .LookIn = "D:\pic\" & r '
        .SearchSubFolders = True
        .Filename = "*"
        If .Execute() > 0 Then
            With Range("A3")
                Set Img1 = ActiveSheet.Shapes.AddPicture( _
                Filename:="D:\pic\111" & r.Offset(0, -1).Value & ".jpg", LinkToFile:=False, _
                SaveWithDocument:=True, Left:=.Left, Top:=.Top, _
                Width:=250, Height:=250)
            End With
            With Range("F3")
                Set Img2 = ActiveSheet.Shapes.AddPicture( _
                Filename:="D:\pic\map" & r.Offset(0, -1).Value & ".jpg", LinkToFile:=False, _
                SaveWithDocument:=True, Left:=.Left, Top:=.Top, _
                Width:=250, Height:=250)
            End With
        Else
            MsgBox "There were no files found."
            Exit Sub
        End If
    End With
    
End Sub

[snasui]

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

[dal252244]

ผมลองทำแบบนี้ทำได้แต่ยังต้องสร้าง ปุ่มกด และมาได้แค่รูปเดียว เวลาจะสร้างอีกรูป ก็รันได้ที่ละอันคับ อยากจะทำให้คีย์รหัสแล้วรูปขึ้นทั้งสองรูปเลยครับ
ปล.ผมไม่ค่อยเก่งเรื่อง Vb ครับ แต่อยากจะทำได้เพื้อจะได้ ขอบคุณคับ

[snasui]

Code ที่เขียนกับไฟล์ที่แนบมาอ้างชื่อชีทไม่ตรงกัน Code ในไฟล์แนบกับที่โพสต์มาตามด้านบนไม่ตรงกันครับ

ให้ทำตามตัวอย่างใน Link นี้ให้ได้ผลลัพธ์ก่อน ซึ่งผมได้บอกไปรอบนึงแล้วครับ http://snasui.blogspot.com/2011/05/folder-excel.html

ลองดูต้นแหล่งที่ไป Copy Code มาครับว่าลักษณะการวางข้อมูลตัวอย่างที่ผมเขียนไว้เป็นแบบใด ก่อนที่จะประยุกต์ไปเป็นแบบอื่น ให้ทำตามตัวอย่างให้ได้ก่อนครับ

[dal252244]

ผมลองเขียน VB ใหม่แล้วคับสามารถดึงรูปมาได้แล้ว แต่อยากจะให้มีรูปเพิ่มใน sheet เดียวกัน ซึ่งมีชื่อรูปเหมือนกันแต่อยู่คนละโฟลเดอร์ ต้องเขียน Code เพิ่มยังไงครับ
ซึ่งผมได้แนบไฟล์มาให้แล้วนะครับ ข้อมูลตามในไฟล์ Book1 เลยครับ

[dal252244]

Code: Select all

Public Sub picshow()
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("d2", .Range("c2").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:\pic\map\" & 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

[bank9597]

ไม่ถนัดเรื่องนี้เลยครับ ต้องรอท่านอื่นมาช่วยดูอรกทีน่ะครับ

[snasui]

ลองปรับ Code เป็นตามด้านล่างครับ

Code: Select all

Public Sub picshow()
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("d2", .Range("c2").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:\pic\map\" & Range("C2").Value & ".jpg", LinkToFile:=False, _
        SaveWithDocument:=True, Left:=Range("D2").Left, Top:=Range("D2").Top, _
        Width:=Range("D2").Width, Height:=Range("D2").Height)
        Set imgIcon = ActiveSheet.Shapes.AddPicture( _
        Filename:="D:\pic\111\" & Range("C2").Value & ".jpg", LinkToFile:=False, _
        SaveWithDocument:=True, Left:=Range("H2").Left, Top:=Range("H2").Top, _
        Width:=Range("H2").Width, Height:=Range("H2").Height)
'    Next r
End Sub

[dal252244]

ทำได้แล้วครับ ขอบคุณมากครับ

[dal252244]

ถ้าต้องการดึงรูปภาพมาโดยไม่ต้องกดปุ่ม Show จะได้ต้องเขียน สูตรอย่างไรครับ

Code: Select all

Public Sub picshow()
Dim r As Range, ra As Range
    Dim imgIcon As Object
    Dim obj As Object
    On Error Resume Next
'    With Worksheets("302")
'        Set ra = .Range("c116", .Range("b116").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:\302\map\" & Range("b116").Value & ".jpg", LinkToFile:=False, _
        SaveWithDocument:=True, Left:=Range("c116").Left, Top:=Range("c116").Top, _
        Width:=250, Height:=250)
        Set imgIcon = ActiveSheet.Shapes.AddPicture( _
        Filename:="D:\302\pic1\" & Range("b116").Value & ".jpg", LinkToFile:=False, _
        SaveWithDocument:=True, Left:=Range("n116").Left, Top:=Range("n116").Top, _
        Width:=250, Height:=250)
'    Next r
End Sub

[snasui]

ไม่กดปุ่ม Show แล้วต้องการให้แสดงรูปเมื่อมีเหตุการณ์ใดเกิดขึ้นครับ

[dal252244]

เมื่อใส่ ID ในช่องเซล T3 แล้วกด Enter ครับ (ขอโทษด้วยนะครับทีี่ให้รายละเอียดไม่ครบ)

[snasui]

ลองวาง Code ด้านล่างนี้ใน VBE ที่ชีท 302 ครับ

Code: Select all

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address = "$T$3" Then
        Call picshow
    End If
End Sub