เพื่อมุ่งให้เกิดคุณภาพจากการอบรมสูงสุด Excel Expert Training ให้การอบรม Excel กลุ่มเล็กๆ ไม่เกิน 6 คนทุกคนสามารถเรียนรู้ Excel อย่างใกล้ชิด จะมาคนเดียวหรือมาเป็นกลุ่มแล้วนัดวันอบรมแบบส่วนตัวก็ได้ ผู้เข้าอบรมทุกคนสามารถติดตามเนื้อหาที่อบรมได้อย่างชัดเจนจากจอภาพด้านหน้าของตัวเอง
Page 3 of 7 FirstFirst 12345 ... LastLast
Results 21 to 30 of 65

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

  1. #21
    widtara
    Guest

    เจอ code เกี่ยวกับการดึงภาพ

    Quote Originally Posted by orange_soi9 View Post
    ลองศึกษาและพยายามเขียน 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

  2. #22
    widtara
    Guest

    มีตัวอย่างมาให้ดูแต่ผสมกับโค้ดเดิมไม่เป็น

    Quote Originally Posted by excel_fever View Post
    ภาพที่ 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
    แต่จากตัวอย่างเขามีปุ่มด้วย อ้อยทำไม่เป็นเหมือนเขาค่ะ

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

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

  4. #24
    pooky
    Guest
    Quote Originally Posted by widtara View Post
    ดึงได้แล้วค่ะแต่ภาพไม่อยู่ในพื้นที่ที่กำหนด
    แต่จะไปอยู่ในช่วง 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

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

  6. #26
    pooky
    Guest
    Quote Originally Posted by excel_fever View Post
    ตรงคำสั่งจัดภาพที่สองน่าจะเป็น L43 นะครับ เพราะเขียนสูตรที่ L43
    ผิดตำแหน่งจริงๆด้วย แก้ไขแล้วค่ะโดยการลบออก เพราะมี selectionอยู่แล้ว

  7. #27
    pooky
    Guest
    ขอปรับปรุงcodeใหม่ เนื่องจากทดลองแล้ว code จะให้ปรับขนาดภาพตาม Height หรือ Width
    อย่างไดอย่างหนึ่งแล้วอีกด้านจะขยายตามเอง ปัญหาคือถ้าตั้งให้ขยายตาม Width ภาพที่มีขนาดHeight>Widthจะล้นลงมาด้านล่าง
    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
          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

  8. #28
    widtara
    Guest

    รายงานผล

    Quote Originally Posted by pooky View Post
    ขอปรับปรุงcodeใหม่ เนื่องจากทดลองแล้ว code จะให้ปรับขนาดภาพตาม Height หรือ Width
    อย่างไดอย่างหนึ่งแล้วอีกด้านจะขยายตามเอง ปัญหาคือถ้าตั้งให้ขยายตาม Width ภาพที่มีขนาดHeight>Widthจะล้นลงมาด้านล่าง
    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
          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 พอรันออกมาแล้ว แสดงตัวหนังสือเป็นสีดำ แต่กำหนดไว้ตอนแรกให้เป็น สีขาว เพื่อไม่แสดงให้เห็น ต้องการให้เป็นตัวหนังสือสีขาวเลยจะเขียนคำสั่งแบบไหนค่ะ
    มีภาพผลลัพธ์มาให้ดูค่ะ

  9. #29
    widtara
    Guest

    ผลงานที่ดัดแปลงเพิ่มเติม

    Quote Originally Posted by widtara View Post
    คำสั่งใช้งานได้ดีค่ะ แต่ยังติดนิดหนึ่งค่ะ ภาพที่วิ่งมา 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 ไม่อยากให้ขึ้นมาค่ะ

  10. #30
    widtara
    Guest

    มีคำสั่งที่กำหนดให้ภาพที่ 2 มีขนาดเท่ากับภาพที่1

    Quote Originally Posted by widtara View Post
    อ้อยเปลี่ยนตำแหน่งค่ะ
    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 ภาพมีขนาดเท่ากันค่ะ

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •