iT邦幫忙

0

關於excel vba代碼圖片與楕圓框群組一問

  • 分享至 

  • xImage
  •  

關於excel vba代碼一問
想請教,當我執行代碼之後
要讓圖片和產生的圖形楕圓框做群組,要怎麼做修改???
請大哥大姐們幫忙看一下,謝謝您~假日愉快

Sub InsertPictureWithRedOvalInGColumn()
    Dim ws As Worksheet
    Dim pic As Picture
    Dim picPath As Variant
    Dim fd As FileDialog
    Dim rng As Range
    Dim targetCell As Range
    Dim foundCell As Boolean
    

    Set ws = ThisWorkbook.Worksheets("Sheet1")
    

    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    With fd
        .AllowMultiSelect = True
        .Title = "選擇圖片"
        .Filters.Add "圖片檔案", "*.jpg; *.jpeg; *.png; *.gif"
        
        If .Show = -1 Then
            For Each picPath In .SelectedItems
                Set rng = ws.Range("G3:G" & ws.Cells(ws.Rows.Count, "G").End(xlUp).Row)
                

                Set targetCell = rng.Cells(3)
                

                foundCell = False
                For Each pic In ws.Pictures
                    If Not Intersect(pic.TopLeftCell, targetCell) Is Nothing Then
                      
                        Set targetCell = targetCell.Offset(1)
                    End If
                Next pic
                
  
                Set pic = ws.Pictures.Insert(picPath)
                
                pic.shapeRange.LockAspectRatio = msoFalse
                pic.Width = targetCell.Width
                pic.Height = targetCell.Height
                

                pic.Top = targetCell.Top
                pic.Left = targetCell.Left
                
                Dim ovalWidth As Double
                Dim ovalHeight As Double
                ovalWidth = pic.Width / 2
                ovalHeight = pic.Height / 2
                Dim oval As Shape
                Set oval = ws.shapes.AddShape(msoShapeOval, pic.Left + (pic.Width - ovalWidth) / 2, _
                    pic.Top + (pic.Height - ovalHeight) / 2, ovalWidth, ovalHeight)
                oval.Fill.Visible = msoFalse
                oval.Line.ForeColor.RGB = RGB(255, 0, 0)
                

                Set targetCell = targetCell.Offset(1)
            Next picPath
        Else
            Exit Sub
        End If
    End With
End Sub

圖片
  直播研討會
圖片
{{ item.channelVendor }} {{ item.webinarstarted }} |
{{ formatDate(item.duration) }}
直播中

尚未有邦友留言

立即登入留言