ให้VBAหาภาพในfoldersและใส่ภาพในไฟล์excelอัตโนมัติ

[widtara]

ลองศึกษาและพยายามเขียน Code ด้วยตัวเองขึ้นมาก่อนดีไหมคะ? ถ้าลองพยายามทำแล้ว แต่ติดขัดปัญหาตรงไหนค่อยมาถามอีกทีนะคะ อาจารย์และทุกคนในที่นี้พร้อมช่วยอยู่แล้วค่ะ :smile:
ลองดู Code จาก Link นี้เป็นตัวอย่างก่อนก็ได้นะคะ
http://excel.bigresource.com/auto-in...-VrrpomxW.html

เจอ code เกี่ยวกับการดึงภาพ แต่มาประยุกต์ไม่เป็นค่ะ คือ code ที่พี่เขาช่วยดูให้ทดลองทำแล้วก็บอกว่า ภาพมาอยู่ในตำแหน่งที่กำหนด แต่อ้อยทดลองทำที่เครื่องหลายต่อหลายครั้งก็ยังไม่สำเร็จค่ะ
เห็น code นี้อยู่เห็นมีการกำหนด ActiveSheet.Range("c3:d9")
คิดว่าของเราน่าจะกำหนดดูบาง แต่พอไปทำไม่ได้ผลเลย มึนกำลังสองเลยค่ะ

Option Explicit

'With the macro below you can insert pictures and fit them to any range in a worksheet.

Option Explicit
Sub InsertPicInRange()
With Application
.ScreenUpdating = False
Dim picToOpen As String
picToOpen = .GetOpenFilename("Pics (*.bmp), *.bmp")
If picToOpen <> "" Then
InsertPictureInRange picToOpen, ActiveSheet.Range("c3:d9")
End If
.ScreenUpdating = True
End With
End Sub

Sub InsertPictureInRange(PictureFileName As String, TargetCells As Range)
' inserts a picture and resizes it to fit the TargetCells range
Dim p As Object, t As Double, l As Double, w As Double, h As Double
If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
If Dir(PictureFileName) = "" Then Exit Sub
' import picture
Set p = ActiveSheet.Pictures.Insert(PictureFileName)
' determine positions
With TargetCells
t = .Top
l = .Left
w = .Offset(0, .Columns.Count).Left - .Left
h = .Offset(.Rows.Count, 0).Top - .Top
End With
' position picture
With p
.Top = t
.Left = l
.Width = w
.Height = h
End With
Set p = Nothing
End Sub

[widtara]

ภาพที่ 1 ถูกแทรกที่ C43
ภาพที่ 2 ถูกแทรกที่ L43
รหัสถูกต้องครับ ผมเองก็ทดสอบแล้ว
และเรื่องขนาดภาพ ผมเคยเตือนตั้งแต่ตอนต้นแล้ว

เรื่องทำได้หรือไม่ได้ จึงยังไม่ขอตอบครับ

คุณ was ค่ะ มีตัวอย่างมาให้ดูค่ะ แต่อ้อยผสมกับ code เดิมเพื่อให้แยกชีทของเดิมไม่เป็นค่ะ
Code ปัจจุบัน
Sub Macro1()
Dim i As Integer
For i = 1 To ThisWorkbook.Worksheets.Count
ThisWorkbook.Worksheets(i).Copy
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & Range("o4").Value & Range("j13").Value & ".xls", FileFormat:=xlExcel8, CreateBackup:=False
Range("c43").Select
Selection.FormulaR1C1 = "=R[71]C[1]&""\""&R[72]C[1]&""\""&R[73]C[1]&""\""&R[74]C[1]&""\""&R[75]C[1]&""\""&R119C4"
ActiveSheet.Pictures.Insert (Selection.Value)
Range("l43").Select
Selection.FormulaR1C1 = "=R[71]C[-8]&""\""&R[72]C[-8]&""\""&R[73]C[-8]&""\""&R[74]C[-8]&""\""&R[75]C[-8]&""\""&R120C4"
ActiveSheet.Pictures.Insert (Selection.Value)
Application.DisplayAlerts = False
ActiveWorkbook.Close True
Next i
End Sub

Code แนะนำมาค่ะ
Sub ShowPicture1()
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("G4", .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:\" & 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
โดยมีตัวอย่างจาก http://******.blogspot.com/2011/05/folder-excel.html
แต่จากตัวอย่างเขามีปุ่มด้วย อ้อยทำไม่เป็นเหมือนเขาค่ะ

[excel_fever]

พื้นที่ที่จะแทรกภาพ เป็นแนวตั้ง แต่ภาพเป็นแนวนอน ย่อหรือขยายแล้วก็ผิดรูปร่าง แถมภาพนั้น Dimension อาจใหญ่มาก ๆ ถึงจะย่อลงแล้วก็ยังไม่ได้ Compress ทำให้ไฟล์มีขนาดใหญ่ตามไปด้วย ผมถึงได้บอกให้แต่งภาพก่อนไงครับ

ส่วนที่บอกว่าแปล Code ไม่ออกนั้นให้ลองเปิดไฟล์ที่ได้จากการแยกชีต (ที่ผมแนบไปให้) ดูที่เซลล์ C43 กับ L43 จะเป็นสูตรอยู่ นั่นแหละครับคือสูตรที่ได้จากบรรทัด Selection.FormulaR1C1=......

[pooky]

ดึงได้แล้วค่ะแต่ภาพไม่อยู่ในพื้นที่ที่กำหนด
แต่จะไปอยู่ในช่วง D3 ถึง D20 และ ภาพ 2 ภาพ ก็ซ้อนทับกันอยู่ค่ะ
ขนาดภาพ 16.92 x 22.57 และต้องการกำหนดให้ภาพมีขนาด 13 x 17.34 จะกำหนดได้ไหมค่ะ

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

Sub Macro1()
Dim i As Integer
For i = 1 To ThisWorkbook.Worksheets.Count
ThisWorkbook.Worksheets(i).Copy
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & Range("o4").Value & Range("j13").Value & ".xls", FileFormat:=xlExcel8, CreateBackup:=False
Range("c43").Select
Selection.FormulaR1C1 = "=R[71]C[1]&""\""&R[72]C[1]&""\""&R[73]C[1]&""\""&R[74]C[1]&""\""&R[75]C[1]&""\""&R119C4"

with ActiveSheet.Pictures.Insert (Selection.Value)
.Top = Range("c43:j94").Top
.Left = Range("c43:j94").Left
.Height = Range("c43:j94").Height
.Width = Range("c43:j94").Width
end with

Range("l43").Select
Selection.FormulaR1C1 = "=R[71]C[-8]&""\""&R[72]C[-8]&""\""&R[73]C[-8]&""\""&R[74]C[-8]&""\""&R[75]C[-8]&""\""&R120C4"

with ActiveSheet.Pictures.Insert (Selection.Value)
.Top = Range("k43:v94").Top
.Left = Range("k43:v94").Left
.Height = Range("k43:v94").Height
.Width = Range("k43:v94").Width
end with

Application.DisplayAlerts = False
ActiveWorkbook.Close True
Next i
End Sub

[excel_fever]

ตรงคำสั่งจัดภาพที่สองน่าจะเป็น L43 นะครับ เพราะเขียนสูตรที่ L43

[pooky]

ตรงคำสั่งจัดภาพที่สองน่าจะเป็น L43 นะครับ เพราะเขียนสูตรที่ L43

ผิดตำแหน่งจริงๆด้วย แก้ไขแล้วค่ะโดยการลบออก เพราะมี selectionอยู่แล้ว

[pooky]

ขอปรับปรุงcodeใหม่ เนื่องจากทดลองแล้ว code จะให้ปรับขนาดภาพตาม Height หรือ Width
อย่างไดอย่างหนึ่งแล้วอีกด้านจะขยายตามเอง ปัญหาคือถ้าตั้งให้ขยายตาม Width ภาพที่มีขนาดHeight>Widthจะล้นลงมาด้านล่าง

Sub Macro1()
Dim i As Integer
For i = 1 To ThisWorkbook.Worksheets.Count
ThisWorkbook.Worksheets(i).Copy
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" &   Range("o4").Value & Range("j13").Value & ".xls",   FileFormat:=xlExcel8, CreateBackup:=False
Range("c43").Select
Selection.FormulaR1C1 =   "=R[71]C[1]&""\""&R[72]C[1]&""\""&R[73]C[1]&""\""&R[74]C[1]&""\""&R[75]C[1]&""\""&R119C4"

with ActiveSheet.Pictures.Insert (Selection.Value)
     .Top = Range("c43:j94").Top
    .Left = Range("c43:j94").Left
      If .Height > .Width Then
        .Height = Range("c43:j94").Height
    Else
       .Width = Range("c43:j94").Width
    End If
end with

Range("l43").Select
Selection.FormulaR1C1 =   "=R[71]C[-8]&""\""&R[72]C[-8]&""\""&R[73]C[-8]&""\""&R[74]C[-8]&""\""&R[75]C[-8]&""\""&R120C4"

 with ActiveSheet.Pictures.Insert (Selection.Value)
     .Top = Range("k43:v94").Top
    .Left = Range("k43:v94").Left
      If .Height > .Width Then
        .Height = Range("k43:v94").Height
    Else
       .Width = Range("k43:v94").Width
    End If
end with

Application.DisplayAlerts = False
ActiveWorkbook.Close True
Next i
End Sub

[widtara]

ขอปรับปรุงcodeใหม่ เนื่องจากทดลองแล้ว code จะให้ปรับขนาดภาพตาม Height หรือ Width
อย่างไดอย่างหนึ่งแล้วอีกด้านจะขยายตามเอง ปัญหาคือถ้าตั้งให้ขยายตาม Width ภาพที่มีขนาดHeight>Widthจะล้นลงมาด้านล่าง

Sub Macro1()
Dim i As Integer
For i = 1 To ThisWorkbook.Worksheets.Count
ThisWorkbook.Worksheets(i).Copy
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" &   Range("o4").Value & Range("j13").Value & ".xls",   FileFormat:=xlExcel8, CreateBackup:=False
Range("c43").Select
Selection.FormulaR1C1 =   "=R[71]C[1]&""\""&R[72]C[1]&""\""&R[73]C[1]&""\""&R[74]C[1]&""\""&R[75]C[1]&""\""&R119C4"

with ActiveSheet.Pictures.Insert (Selection.Value)
     .Top = Range("c43:j94").Top
    .Left = Range("c43:j94").Left
      If .Height > .Width Then
        .Height = Range("c43:j94").Height
    Else
       .Width = Range("c43:j94").Width
    End If
end with

Range("l43").Select
Selection.FormulaR1C1 =   "=R[71]C[-8]&""\""&R[72]C[-8]&""\""&R[73]C[-8]&""\""&R[74]C[-8]&""\""&R[75]C[-8]&""\""&R120C4"

 with ActiveSheet.Pictures.Insert (Selection.Value)
     .Top = Range("k43:v94").Top
    .Left = Range("k43:v94").Left
      If .Height > .Width Then
        .Height = Range("k43:v94").Height
    Else
       .Width = Range("k43:v94").Width
    End If
end with

Application.DisplayAlerts = False
ActiveWorkbook.Close True
Next i
End Sub

คำสั่งใช้งานได้ดีค่ะ แต่ยังติดนิดหนึ่งค่ะ ภาพที่วิ่งมา 2 ภาพ ไปปิดหัวเรื่องไว้
ขนาดภาพไม่เท่ากัน
ขนาดไฟล์ประมาณ 340-355 อ้อยต้องมาทำการ cut ภาพ แล้ววางแบบ JPG ขนาดไฟล์จะเหลือประมาณ 150-200
ที่ C43 และ L43 พอรันออกมาแล้ว แสดงตัวหนังสือเป็นสีดำ แต่กำหนดไว้ตอนแรกให้เป็น สีขาว เพื่อไม่แสดงให้เห็น ต้องการให้เป็นตัวหนังสือสีขาวเลยจะเขียนคำสั่งแบบไหนค่ะ
มีภาพผลลัพธ์มาให้ดูค่ะ

[widtara]

คำสั่งใช้งานได้ดีค่ะ แต่ยังติดนิดหนึ่งค่ะ ภาพที่วิ่งมา 2 ภาพ ไปปิดหัวเรื่องไว้
ขนาดภาพไม่เท่ากัน
ขนาดไฟล์ประมาณ 340-355 อ้อยต้องมาทำการ cut ภาพ แล้ววางแบบ JPG ขนาดไฟล์จะเหลือประมาณ 150-200
ที่ C43 และ L43 พอรันออกมาแล้ว แสดงตัวหนังสือเป็นสีดำ แต่กำหนดไว้ตอนแรกให้เป็น สีขาว เพื่อไม่แสดงให้เห็น ต้องการให้เป็นตัวหนังสือสีขาวเลยจะเขียนคำสั่งแบบไหนค่ะ
มีภาพผลลัพธ์มาให้ดูค่ะ

อ้อยเปลี่ยนตำแหน่งค่ะ
With ActiveSheet.Pictures.Insert(Selection.Value)
.Top = Range("f52:j86").Top
.Left = Range("f52:j86").Left
If .Height > .Width Then
.Height = Range("f52:j86").Height
Else
.Width = Range("f52:j86").Width
End If
End With
Range("l43").Select
Selection.FormulaR1C1 = "=R[71]C[-8]&""\""&R[72]C[-8]&""\""&R[73]C[-8]&""\""&R[74]C[-8]&""\""&R[75]C[-8]&""\""&R120C4"
With ActiveSheet.Pictures.Insert(Selection.Value)
.Top = Range("m52:s86").Top
.Left = Range("m52:s86").Left
If .Height > .Width Then
.Height = Range("m52:s86").Height
Else
.Width = Range("m52:s86").Width
End If
End With

ได้ผลลัพธ์ดังภาพค่ะ:yesnod: แต่งงคือขนาดภาพ ที่1 มันจะใหญ่กว่าภาพที่ 2 ทั้งที่ถ่ายมาก็ตั้งกล้องรีไซด์แล้ว เป็นแบบส่งเมล์ ไม่ทราบสาเหตุ ค่ะ ขนาดไฟล์ที่ได้ 336 KB ขนาดภาพตาม ภาพที่ 1 กำลังดีค่ะ ไม่ต้องมาย่อภาพอีกเลย คือ 15.11 cm x 20.53 cm

หลังจากทำการคลิกขวา ตัดภาพ 2 ภาพ และวางแบบ jpg ใหม่ ได้ขนาดไฟล์เพียง 148 KB

อยากทราบว่า VBA ที่กำหนด เราก็เรียกภาพ เป็น JPG แล้ว ทำไม มันใหญ่ถึง 336 KB เราต้องมาตัดภาพวาง เป็น JPG ถึงจะได้ไฟล์ที่เล็กลง

เราสามารถกำหนดไฟล์ให้เล็กเป็นกว่านี้ได้ไหมค่ะ เป็นการส่งเมล์ทุกไฟล์ที่ทำค่ะ

ส่วนเรื่องตัวหนังสือก็จัดการเรียบร้อยแล้วค่ะ ยังสงสัยแค่เรื่องขนาดภาพ กับขนาดไฟล์ค่ะ:nonod:


ขอแทรกอีกเรื่องหนึ่งนะค่ะ มีใครช่วยกำหนดให้ภาพที่ 2 ไม่ให้แสดงได้ไหมค่ะ ที่บริษัทใช้ 2007 ไม่อยากให้ขึ้นมาค่ะ

[widtara]

อ้อยเปลี่ยนตำแหน่งค่ะ
With ActiveSheet.Pictures.Insert(Selection.Value)
.Top = Range("f52:j86").Top
.Left = Range("f52:j86").Left
If .Height > .Width Then
.Height = Range("f52:j86").Height
Else
.Width = Range("f52:j86").Width
End If
End With
Range("l43").Select
Selection.FormulaR1C1 = "=R[71]C[-8]&""\""&R[72]C[-8]&""\""&R[73]C[-8]&""\""&R[74]C[-8]&""\""&R[75]C[-8]&""\""&R120C4"
With ActiveSheet.Pictures.Insert(Selection.Value)
.Top = Range("m52:s86").Top
.Left = Range("m52:s86").Left
If .Height > .Width Then
.Height = Range("m52:s86").Height
Else
.Width = Range("m52:s86").Width
End If
End With

ได้ผลลัพธ์ดังภาพค่ะ:yesnod: แต่งงคือขนาดภาพ ที่1 มันจะใหญ่กว่าภาพที่ 2 ทั้งที่ถ่ายมาก็ตั้งกล้องรีไซด์แล้ว เป็นแบบส่งเมล์ ไม่ทราบสาเหตุ ค่ะ ขนาดไฟล์ที่ได้ 336 KB ขนาดภาพตาม ภาพที่ 1 กำลังดีค่ะ ไม่ต้องมาย่อภาพอีกเลย คือ 15.11 cm x 20.53 cm

หลังจากทำการคลิกขวา ตัดภาพ 2 ภาพ และวางแบบ jpg ใหม่ ได้ขนาดไฟล์เพียง 148 KB

อยากทราบว่า VBA ที่กำหนด เราก็เรียกภาพ เป็น JPG แล้ว ทำไม มันใหญ่ถึง 336 KB เราต้องมาตัดภาพวาง เป็น JPG ถึงจะได้ไฟล์ที่เล็กลง

เราสามารถกำหนดไฟล์ให้เล็กเป็นกว่านี้ได้ไหมค่ะ เป็นการส่งเมล์ทุกไฟล์ที่ทำค่ะ

ส่วนเรื่องตัวหนังสือก็จัดการเรียบร้อยแล้วค่ะ ยังสงสัยแค่เรื่องขนาดภาพ กับขนาดไฟล์ค่ะ:nonod:


ขอแทรกอีกเรื่องหนึ่งนะค่ะ มีใครช่วยกำหนดให้ภาพที่ 2 ไม่ให้แสดงได้ไหมค่ะ ที่บริษัทใช้ 2007 ไม่อยากให้ขึ้นมาค่ะ

มีคำสั่งที่กำหนดให้ภาพที่ 2 มีขนาดเท่ากับภาพที่1 ไหมค่ะ ต้องการให้รันไฟล์แล้ว ภาพ 2 ภาพมีขนาดเท่ากันค่ะ