ช่วยปรับโค๊ดด้านล่างให้สามารถอัพโหลดรูปภาพได้ให้พอดีกับขนาด เซลล์ที่กำหนด

[SuminO]

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

ผมลองปรับโค๊ดแล้ว มันมีขนาดไมเท่ากันครับ

Code: Select all

Sub InsertPictures()
    Dim ws As Worksheet
    Dim Pic As Picture
    Dim PicPath As String
    Dim cell As Range
    Dim r As Long
    Dim c As Long
    Dim PicWidth As Double
    Dim PicHeight As Double
    Dim TargetRange As Range
    Dim RowHeight As Double
    Dim ColumnWidth As Double

    Set ws = ThisWorkbook.Sheets("Sheet1")
    
  
    Set TargetRange = ws.Range("A2:B2,A4:B4,A6:B6,A8:B8,A10:B10") '
    
    For Each cell In TargetRange.Cells

        With Application.FileDialog(msoFileDialogFilePicker)
            .Title = "Select Picture"
            .Filters.Clear
            .Filters.Add "Images", "*.jpg; *.jpeg; *.png; *.bmp; *.gif"
            If .Show = -1 Then
                PicPath = .SelectedItems(1)
            Else
                Exit Sub
            End If
        End With

        Set Pic = ws.Pictures.Insert(PicPath)

        RowHeight = cell.Height
        ColumnWidth = cell.Width

        PicWidth = Pic.Width
        PicHeight = Pic.Height
        
        If PicWidth / ColumnWidth > PicHeight / RowHeight Then
            Pic.Width = ColumnWidth - 10
            Pic.Height = Pic.Height * ((ColumnWidth - 10) / PicWidth)
        Else
            Pic.Height = RowHeight - 20
            Pic.Width = Pic.Width * ((RowHeight - 20) / PicHeight)
        End If
        
  
        Pic.Top = cell.Top + 5
        Pic.Left = cell.Left + 5
        

        With ws.Shapes.AddTextbox(msoTextOrientationHorizontal, Pic.Left, Pic.Top + Pic.Height + 5, Pic.Width, 15)
            .TextFrame.Characters.Text = "Your Text Here"
            .TextFrame.HorizontalAlignment = xlHAlignCenter
            .Line.Visible = msoFalse
        End With
    Next cell
End Sub

[snasui]

ตัวอย่าง Code ครับ

Code: Select all

Sub InsertPictures()
    Dim p As Object
    Dim picPath As String
    Dim ws As Worksheet
    Dim TargetRange As Range
    
    Set ws = ThisWorkbook.Sheets("Sheet1")
    Set TargetRange = ws.Range("A2:B2,A4:B4,A6:B6,A8:B8,A10:B10")
    
    For Each cell In TargetRange.Cells
        With Application.FileDialog(msoFileDialogFilePicker)
            .Title = "Select Picture"
            .Filters.Clear
            .Filters.Add "Images", "*.jpg; *.jpeg; *.png; *.bmp; *.gif"
            If .Show = -1 Then
                picPath = .SelectedItems(1)
            Else
                Exit Sub
            End If
            With cell
                .Activate
                Set p = .Parent.Shapes.AddPicture( _
                    Filename:=picPath, _
                    linktofile:=False, _
                    savewithdocument:=True, _
                    Left:=.Left, _
                    Top:=.Top, _
                    Width:=.Width, _
                    Height:=.Height)
            End With
        End With
    Next cell
End Sub

[SuminO]

ขอบคุณมากครับ

แล้วถ้าหากเลือกทีละเยอะ ๆ ละครับ
ต้องเพิ่มส่วนไหน ผมเพิ่ม เข้าไปเป็น
AllowMultiSelect = True

มันเตือน Bug

Code: Select all

Sub InsertPictures()
    Dim p As Object
    Dim picPaths As Variant
    Dim ws As Worksheet
    Dim TargetRange As Range
    Dim cell As Range
    Dim i As Integer
    
    Set ws = ThisWorkbook.Sheets("Sheet1")
    Set TargetRange = ws.Range("A2:B2,A4:B4,A6:B6,A8:B8,A10:B10")
    
    With Application.FileDialog(msoFileDialogFilePicker)
        .Title = "Select Pictures"
        .Filters.Clear
        .Filters.Add "Images", "*.jpg; *.jpeg; *.png; *.bmp; *.gif"
        .AllowMultiSelect = True ' Allow multiple file selection
        If .Show = -1 Then
            picPaths = .SelectedItems
        Else
            Exit Sub
        End If
    End With
    
    i = 1 ' Initialize index for target range
    For Each cell In TargetRange.Cells
        If i > UBound(picPaths) Then Exit For ' Exit if there are no more pictures to insert
        With cell
            .Activate
            Set p = .Parent.Shapes.AddPicture( _
                Filename:=picPaths(i), _
                linktofile:=False, _
                savewithdocument:=True, _
                Left:=.Left, _
                Top:=.Top, _
                Width:=.Width, _
                Height:=.Height)
        End With
        i = i + 1 ' Move to the next picture
    Next cell
End Sub

[snasui]

ตัวอย่างการปรับ Code ครับ

Code: Select all

Sub InsertPictures()
    Dim p As Object
    Dim picPaths As FileDialogSelectedItems
    Dim ws As Worksheet
    Dim TargetRange As Range
    Dim cell As Range
    Dim i As Integer
    
    Set ws = ThisWorkbook.Sheets("Sheet1")
    Set TargetRange = ws.Range("A2:B2,A4:B4,A6:B6,A8:B8,A10:B10")
    With Application.FileDialog(msoFileDialogFilePicker)
        .Title = "Select Pictures"
        .Filters.Clear
        .Filters.Add "Images", "*.jpg; *.jpeg; *.png; *.bmp; *.gif"
        .AllowMultiSelect = True ' Allow multiple file selection
        If .Show = -1 Then
            Set picPaths = .SelectedItems
        Else
            Exit Sub
        End If
    End With
    
    i = 1 ' Initialize index for target range
    For Each cell In TargetRange.Cells
        With cell
            .Activate
            Set p = .Parent.Shapes.AddPicture( _
                Filename:=picPaths(i), _
                linktofile:=False, _
                savewithdocument:=True, _
                Left:=.Left, _
                Top:=.Top, _
                Width:=.Width, _
                Height:=.Height)
        End With
        i = i + 1 ' Move to the next picture
        If i > picPaths.Count Then Exit Sub
    Next cell
End Sub

[SuminO]

ขอบคุณมากๆครับ

แต่ยังเออเร่อครับอาจารย์ผมเพิ่มช่วงเข้าไปแล้ว
มันError ช่วงนี้ครับ
Set TargetRange = ws.Range("A4, D4, A6, D6, A8, D8, " & _
"A13, D13, A15, D15, A17, D17, " & _
"A22, D22, A24, D24, A26, D26, " & _
"A31, D31, A33, D33, A35, D35, " & _
"A40, D40, A42, D42, A44, D44, " & _
"A49, D49, A51, D51, A53, D53, " & _
"A58, D58, A60, D60, A62, D62, " & _
"A67, D67, A69, D69, A71, D71, " & _
"A76, D76, A78, D78, A80, D80, " & _
"A85, D85, A87, D87, A89, D89")

Code: Select all

Sub InsertPictures()
    Dim p As Object
    Dim picPaths As FileDialogSelectedItems
    Dim ws As Worksheet
    Dim TargetRange As Range
    Dim cell As Range
    Dim i As Integer
    
    Set ws = ThisWorkbook.Sheets("Sheet1")
      Set TargetRange = ws.Range("A4, D4, A6, D6, A8, D8, " & _
                               "A13, D13, A15, D15, A17, D17, " & _
                               "A22, D22, A24, D24, A26, D26, " & _
                               "A31, D31, A33, D33, A35, D35, " & _
                               "A40, D40, A42, D42, A44, D44, " & _
                               "A49, D49, A51, D51, A53, D53, " & _
                               "A58, D58, A60, D60, A62, D62, " & _
                               "A67, D67, A69, D69, A71, D71, " & _
                               "A76, D76, A78, D78, A80, D80, " & _
                               "A85, D85, A87, D87, A89, D89")
    With Application.FileDialog(msoFileDialogFilePicker)
        .Title = "Select Pictures"
        .Filters.Clear
        .Filters.Add "Images", "*.jpg; *.jpeg; *.png; *.bmp; *.gif"
        .AllowMultiSelect = True ' Allow multiple file selection
        If .Show = -1 Then
            Set picPaths = .SelectedItems
        Else
            Exit Sub
        End If
    End With
    
    i = 1 ' Initialize index for target range
    For Each cell In TargetRange.Cells
        With cell
            .Activate
            Set p = .Parent.Shapes.AddPicture( _
                Filename:=picPaths(i), _
                linktofile:=False, _
                savewithdocument:=True, _
                Left:=.Left, _
                Top:=.Top, _
                Width:=.Width, _
                Height:=.Height)
        End With
        i = i + 1 ' Move to the next picture
        If i > picPaths.Count Then Exit Sub
    Next cell
End Sub

[snasui]

เข้าใจว่าเกิดอักขระแปลกปลอมอยู่ใน String นั้น ลองปรับเป็นด้านล่างครับ

Code: Select all

'Other code
    Set TargetRange = ws.Range("A4,D4,A6,D6,A8,D8," & _
                                "A13,D13,A15,D15,A17,D17," & _
                                "A22,D22,A24,D24,A26,D26," & _
                                "A31,D31,A33,D33,A35,D35," & _
                                "A40,D40,A42,D42,A44,D44," & _
                                "A49,D49,A51,D51,A53,D53," & _
                                "A58,D58,A60,D60,A62,D62," & _
                                "A67,D67,A69,D69,A71,D71," & _
                                "A76,D76,A78,D78,A80,D80," & _
                                "A85,D85,A87,D87,A89,D89")
'Other code