图片群组名重复

cmo9020

test222.rar (331.72 KB, 下载次数: 2)

2023-3-26 09:44 上传

点击文件名下载附件

周末愉快~~请教各位大神导师们~
想请教代码问题,需要怎么样修改才能在下次执行代码时插入图片是从空白处开始

目前代码功能设定是
从G3单元格开始放入图片
插入图片和楕圆图形直接群组，属性设定成"大小固定，位置随单元格而变"

现在一直在反复测试要如何在下次执行时从空白单元格放入
一直卡在Pic群组名重复
请各位导师指点一下~谢谢。



Sub Pic31212133()
    Const xlMoveButNoChange As Integer = 2
   
    Dim folderPath As String
    Dim FilesInFolder As Variant
    Dim Pic As Variant
    Dim shp As shape
    Dim picShp As shape
    Dim groupShp As shape
    Dim rng As Range
    Dim cellHeight As Single
    Dim i As Long
   
    Application.ScreenUpdating = False
      
With Application.FileDialog(msoFileDialogFilePicker)
    .AllowMultiSelect = True
    .Title = "选择要插入的图片档案"
    .Filters.Clear
    .Filters.Add "图片档案", "*.jpg;*.jpeg;*.png;*.bmp", 1
    If .Show = True Then
        ReDim FilesInFolder(1 To .SelectedItems.Count)
        For i = 1 To .SelectedItems.Count
            FilesInFolder(i) = .SelectedItems(i)
        Next i
    Else
        Exit Sub
    End If
End With
   
    If IsEmpty(FilesInFolder) Then
        MsgBox "No image files found in the selected folder."
        Exit Sub
    End If
   
    Sheet5.Columns("G:G").Clear
   
    i = 3 ' 设定初始值为 3
    On Error Resume Next
For Each Pic In FilesInFolder
        
    Set rng = Sheet5.Range("G" & i)
    Set shp = Sheet5.Shapes.AddPicture(Pic, msoFalse, msoTrue, rng.Left, rng.Top, -1, -1)
    shp.Name = "Pic_" & i
   
    ' 计算图片中心点位置
    Dim picCenterLeft As Single
    Dim picCenterTop As Single
    picCenterLeft = shp.Left + (shp.Width / 2)
    picCenterTop = shp.Top + (shp.Height / 2)
   
    Set picShp = Sheet5.Shapes.AddShape(msoShapeOval, picCenterLeft - shp.Width / 4, picCenterTop - shp.Height / 4, shp.Width / 2, shp.Height / 2)
    picShp.Line.ForeColor.RGB = RGB(255, 0, 0)
    picShp.Fill.Transparency = 1
    picShp.Name = "Pic_" & i & "_Oval"
   
    Set groupShp = Sheet5.Shapes.Range(Array(shp.Name, picShp.Name)).Group
    groupShp.Name = "Pic_" & i & "_Group"
   
    With groupShp
        .TopLeftCell = rng
        .Height = rng.Height
        .Width = rng.Width
        .Placement = xlMoveButNoChange
    End With
   
    i = i + 1 '向下移动到下一行的单元格
   
Next Pic
   
    Application.ScreenUpdating = True
   
End Sub
Function GetFiles(ByVal folderPath As String, ByVal filePattern As String) As Variant
Dim arrFiles() As Variant
Dim i As Long
Dim file As Variant
i = 0
file = Dir(folderPath & "\" & filePattern)
Do Until file = ""
    ReDim Preserve arrFiles(i)
    arrFiles(i) = folderPath & "\" & file
    i = i + 1
    file = Dir()
Loop
GetFiles = arrFiles
End Function