如何使用Excel VBA将图像插入数组中的多个列？

dgiusagp 于 2022-12-01 发布在其他

关注(0)|答案(1)|浏览(263)

我开发了代码来从一个文件夹（由用户选择）中搜索图像，并通过一些循环将其放在Excel的一列中。
现在我尝试使用多维数组，这样它也可以将图像插入到多个列中。我尝试创建一个循环，这样它也可以将图像插入到B列中，而不是将图像放在A列中。
我目前取得的成就：

Sub ReadFolder()
'
'ReadFolder
'
Dim File As Variant
Dim Counter As Long
Dim DirectoryList() As String
Dim varResp As Variant
Dim shape as Excel.shape
ReDim DirectoryList(1000)

' check if the user inserted a valid path or if he canceled the operation and offer him a chance to abort the operation or retry 
lblTryAgain:
varResp = InputBox("Type down the files path)", "Path")
If Trim(varResp) = "" Then
    If MsgBox("Do you wish to abort?", vbYesNo + vbQuestion, "Abort?") = vbYes Then
        GoTo lblExit
    Else
        GoTo lblTryAgain
    End If
Else
    File = Dir$(varResp & "\*.*")
    If File = "" Then
        MsgBox "The path doesnt exist , Please retry", vbExclamation, "Fail"
        GoTo lblTryAgain
    End If
End If
On Error GoTo Erro

' fill the array with elements that are inside the file(gotta put then into a 2d array with the dimension (n,2)
Do While File <> ""
    DirectoryList(Counter) = File
    File = Dir$
    Counter = Counter + 1
Loop
' resize the array accordingly to the number of elements filled inside it
ReDim Preserve DirectoryList(Counter - 1)

' delete the images inside the sheet before inserting new ones
For Each shape In Worksheets("Sheet1").Shapes
    shape.Delete
Next

' loop thru the array and put images into columns A and resize the  column, images and rows
For i = 0 To UBound(DirectoryList)
    for j = 0 to 1
        Debug.Print DirectoryList(i)
        With Worksheets("Sheet1").Cells(i+1, j+1)
            Set File = Worksheets("Sheet1").Pictures.Insert(DirectoryList(i))
                    
            File.Top = .Top
            File.Left = .Left
            File.ShapeRange.LockAspectRatio = msoFalse
            File.Placement = xlMoveAndSize
            .ColumnWidth = 30
            .RowHeight = 100
            File.ShapeRange.Width = 170
            File.ShapeRange.Height = 100
        End With
    next j
Next i

lblExit:
    Exit Sub
Erro:
    MsgBox "OOpssie, Fail!", vbCritical, "Error"

End Sub

我希望这样（考虑到文件夹只有4个图像）：

我得到这个：

考虑要点：
1.最后一个图像已更改，因为我不小心删除了它（这不会干扰问题）
1.没有办法告诉多少图像文件夹将有

excel

来源：https://stackoverflow.com/questions/73037020/how-may-i-insert-images-into-multiple-columns-from-an-array-using-excel-vba

1条答案

按热度按时间

vh0rcniy1#

请尝试以下操作：

Sub ReadFolder()
    Const ROW_START As Long = 3  'start row
    Const COL_START As Long = 3  'start column
    Const PER_ROW As Long = 4    'how many pics per row
    Dim File As Variant
    Dim Counter As Long
    Dim DirectoryList() As String
    Dim folder As Variant
    Dim shape As Excel.shape, ws As Worksheet, i As Long, c As Range
    
    'get folder or cancel
    Do
        folder = GetFolderPath("Select the source folder")
        If Len(folder) = 0 Then
            If MsgBox("Abort?", vbYesNo) = vbYes Then Exit Sub
        End If
    Loop While Len(folder) = 0

    'any files?
    File = Dir(folder & "*.png", vbNormal)
    If Len(File) = 0 Then
        MsgBox "No files in this folder"
        Exit Sub
    End If
    
    Set ws = Worksheets("Sheet1")
    For i = ws.Shapes.Count To 1 Step -1
        ws.Shapes(i).Delete
    Next i
    
    Set c = ws.Cells(ROW_START, COL_START) 'start cell for pics
    
    Do While Len(File) > 0
        
        Debug.Print "Inserting at: " & c.Address
        If c.Row = ROW_START Then c.ColumnWidth = 30 'only need to set once per row/column
        If c.Column = COL_START Then c.RowHeight = 100
        
        With ws.Pictures.Insert(folder & File)
            .Placement = xlMoveAndSize
            .Top = c.Top
            .Left = c.Left
            .ShapeRange.LockAspectRatio = msoFalse
            .Width = 170
            .Height = 100
        End With
        
        'where is the next picture going?
        If (c.Column - COL_START) >= PER_ROW - 1 Then         'already at max column?
            Set c = c.Offset(1).EntireRow.Cells(COL_START) 'first cell on next row
        Else
            Set c = c.Offset(0, 1)                 'move one cell over
        End If
        
        File = Dir()
    Loop
    
End Sub

'get a folder from the user - returns empty string if no selection
Function GetFolderPath(msg As String) As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = msg
        If .Show = -1 Then GetFolderPath = .SelectedItems.Item(1) & "\"
    End With
End Function

赞(0）回复(0）举报 2022-12-01

我来回答

如何使用Excel VBA将图像插入数组中的多个列？

1条答案

相关问题

热门标签

最新问答