สอบถาม Code ย่อภาพ

[Leng]

Code: Select all

Sub Macro2()
For i = 3 To Range("b1048576").End(xlUp).Row
Range("c" & i).Select
    ActiveSheet.Pictures.Insert("C:\Users\Administrator\Desktop\Size\" & Range("b" & i).Value & ".jpg").Select
    
    With Selection
    .Height = ActiveCell.Height - 10
    .ShapeRange.IncrementTop 10
    .ShapeRange.IncrementLeft (ActiveCell.Width - Selection.Width) / 2
    End With
    Next i
    End Sub
    

ผมอยากย่อภาพคับโดยใช้ vba แต่ติดตรงว่า ต้องกำหนดชื่อภาพตาม คอลัมน์ ถึงจะrunได้
ผมอยากแก้ให้runได้เลยโดยไม่ต้องเปลี่ยนชื่อภาพครับ

[snasui]

กรุณาแนบไฟล์ที่เขียน Code นี้ไว้แล้วพร้อมตัวอย่างภาพที่จะใช้ย่อจะได้ช่วยทดสอบให้ได้ครับ

[Leng]

Code: Select all

Sub Macro2()
For i = 3 To Range("b1048576").End(xlUp).Row
Range("c" & i).Select
    ActiveSheet.Pictures.Insert("C:\Users\Administrator\Desktop\Size\" & Range("b" & i).Value & ".jpg").Select
    
    With Selection
    .Height = ActiveCell.Height - 10
    .ShapeRange.IncrementTop 10
    .ShapeRange.IncrementLeft (ActiveCell.Width - Selection.Width) / 2
    End With
    Next i
    End Sub
    

ผมอยากย่อภาพคับโดยใช้ vba แต่ติดตรงว่า ต้องกำหนดชื่อภาพตาม คอลัมน์ ถึงจะrunได้
ผมอยากแก้ให้runได้เลยโดยไม่ต้องเปลี่ยนชื่อภาพครับ

[snasui]

Code นั้นต้องแทรกภาพเข้ามาก่อนจากนั้นจึงจะกำหนดขนาด ไม่ทราบว่าที่ต้องการมีลักษณะใด กรุณาลำดับขั้นตอนมาด้วยครับ

หากมีภาพอยู่แล้วก็สามารถจะใช้ For Each...Next เพื่อ Loop ไปยังแต่ละภาพได้ ตัวอย่างการ Loop ดูได้จาก Link นี้ครับ viewtopic.php?t=324#p6197

[Leng]

สิ่งที่ต้องการคือ
-กดปุ่มเพื่อแทรกภาพจาก Folder และย่อขนาด อัตโนมัติครับ
ปัญหา คือ ต้องกำหนดชื่อจากภาพก่อนถึงจะ แทรกภาพเข้ามาได้ครับ

Code: Select all

Sub Macro2()
For i = 3 To Range("b1048576").End(xlUp).Row
Range("c" & i).Select
    ActiveSheet.Pictures.Insert("C:\Users\Administrator\Desktop\Size\" & Range("b" & i).Value & ".jpg").Select
    
    With Selection
    .Height = ActiveCell.Height - 10
    .ShapeRange.IncrementTop 10
    .ShapeRange.IncrementLeft (ActiveCell.Width - Selection.Width) / 2
    End With
    Next i
    End Sub
    

[snasui]

ไม่เข้าใจปัญหาและคิดว่าการทำงานลักษณะนั้นไม่ใช่ปัญหาแต่เป็นการทำงานตามที่สั่ง

ถ้าไม่กำหนดชื่อภาพก่อนจะแทรกเข้ามาได้อย่างไร กรุณาให้รายละเอียดเพิ่มเติมครับ

[Leng]

คือผมอยากให้ดึงภาพทั้งหมดจาก fordel ที่ตั้งไว้ มาลงใน excel ครับ และทำการย่อภาพ ตามที่กำหนด

[snasui]

ก็ต้องใช้วิธีอื่นคือ Loop เข้าไปใน Folder นั้นเพื่อหาไฟล์ภาพ ไม่ใช่วิธีโดยกำหนดชื่อ ลองค่อย ๆ ดูตาม Link เหล่านี้ครับ Loop file in folder

[Leng]

Code: Select all

    Sub FindAndOpenFiles()
    Dim FilePath As String
    Dim fileName As String
    Dim wbFound As Workbook
    FilePath = "C:\Users\Administrator\Desktop\Size"
    fileName = Dir(FilePath & ".jpg")
    Do Until fileName = ""
        Set wbFound = Workbooks.Open( _
            fileName:=FilePath & "\" & fileName)
        fileName = Dir()
    Loop
End Sub

จากที่ได้ศึกษาดูครับ พอทำขึ้นเป็นภาษาต่างดาวครับรบกวนอาจารย์ช่วยดูหน่อยครับ

[snasui]

ไม่ใช่นำไฟล์ต้นฉบับมาใช้แบบไม่มีการปรับปรุง เพราะความมุ่งหมายเป็นคนละอย่าง Code เดิมค้นหาแล้วเปิดไฟล์แต่สิ่งที่ต้องการตามกระทู้นี้เป็นการแทรกภาพ ไม่ใช่เปิดไฟล์ภาพ ลองปรับปรุงด้วย Code การแทรกมาเองก่อน ติดแล้วค่อยถามกันครับ

[Leng]

Code: Select all

Sub Macro1()
Range("A1").Select
Dim picname As String
picname = Range("B4")
ActiveSheet.Pictures.Insert("C:\Users\Administrator\Desktop\Size\" & picname & ".jpg").Select
With Selection
.Left = Range("A1").Left
.Top = Range("A1").Top
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = 150#
.ShapeRange.Width = 150#
.ShapeRange.Rotation = 0#
End With


End Sub

รบกวนอาจารย์ครับ ติดปัญหาคือ ไม่สามารถแทรกภาพให้ run ต่อๆกัน ได้ครับ

[snasui]

นำ Code ในความเห็นตาม #9 มาประกอบกับ #11 เพื่อนำภาพใน Folder มาวางแล้วกำหนดขนาดภาพ

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

[Leng]

Code: Select all

Sub Macro1()
Range("A1").Select
Dim picname As String
For i = 3 To Range("b1048576").End(xlUp).Row
Range("c" & i).Select
picname = Range("B4")
ActiveSheet.Pictures.Insert("C:\Users\Administrator\Desktop\Size\" & picname & ".jpg").Select
With Selection
.Left = Range("A1").Left
.Top = Range("A1").Top
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = 150#
.ShapeRange.Width = 150#
.ShapeRange.Rotation = 0#
 End With
    Next i
End Sub

จากที่ได้ลองเอา code มารวมกันครับ
แต่ติดปัญหาคือ ดึงภาพเดิมมา 3 ภาพครับ แต่ไม่ดึงภาพอื่นที่อยู่ใน forder

[snasui]

ไม่พบว่าได้ใช้การ Loop เข้าไปใน Folder ตามที่ผมได้ตอบไปตามโพสต์ #9 Code แค่นี้ทำงานไม่ได้ ไม่ควรจะนำมาถามซ้ำ ๆ ครับ

[Leng]

Code: Select all

Sub FindAndOpenFiles()
Dim picname As String
ActiveSheet.Pictures.Insert ("C:\Users\Administrator\Desktop\Size")
Do Until picname = ""
For i = 3 To Range("b1048576").End(xlUp).Row
    
    With Selection
.Left = Range("A1").Left
.Top = Range("A1").Top
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = 150#
.ShapeRange.Width = 150#
.ShapeRange.Rotation = 0#
End With
         Next i
         Loop
End Sub

ภาพขึ้นเป็น "ไม่สามารถแสดงภาพได้ครับ" รบกวนอาจารย์ช่วยหน่อยครับ

[Leng]

Code: Select all

Sub FindAndOpenFiles()
    Dim strFolder As String
    Dim strFileName As String
    Dim objPic As Picture
    Dim rngCell As Range

    strFolder = "C:\Users\Administrator\Desktop\Size\"
    If Right(strFolder, 1) <> "\" Then
        strFolder = strFolder & "\"
    End If

    Set rngCell = Range("A1")

    strFileName = Dir(strFolder & "*.jpg", vbNormal)

    Do While Len(strFileName) > 0
        Set objPic = ActiveSheet.Pictures.Insert(strFolder & strFileName)
        With objPic
            .Left = rngCell.Left
            .Top = rngCell.Top
            .Height = rngCell.RowHeight
            .Placement = xlMoveAndSize
        End With
        Set rngCell = rngCell.Offset(1, 0)
        strFileName = Dir
    Loop

End Sub

ทำได้แล้วครับ