Question

我有分配，我需要将图像插入到与该行的样式编号对应的excel中。我习惯于逐个图片插入，然后不得不调整大小，这可能既费时又令人沮丧。

我把一些来自几个不同地方的vba脚本放在一起做了一个了不起的工作。我从一个地方获得了Loop，从另一个地方获得了CenterMe Sub，从第三个地方获得了IsFile。您需要做的就是将文件路径放在第4列中，它会在第一列中为您提供完美大小的图片。

您唯一需要为图像指定高度，然后确保所有方框都大于该高度。您还需要指定范围。

如果有人能够提出一个自动计算单元格高度的解决方案，并且还会通过查找excel的结尾来计算出范围，那么它将是完美的。这是代码：

' I set RowHeight in the excel to 125 and Picture Height to 100 so it fits nicely
' into the box that I want.
' That can be changed to suit your needs.
Sub InsertImageFullName()

    Application.ScreenUpdating = False

    Dim pic As String ' File path of a picture
    Dim cl As Range
    Dim i As Integer

    Set Rng = Range("A2:A117") ' Defining input range
    i = 1
    For Each cl In Rng

        pic = cl.Offset(0, 3)  ' Full path of the picture file:
                               ' Located in the same row, third column from A, i.e. column D
        If IsFile(pic) Then

            Set myPicture = ActiveSheet.Pictures.Insert(pic) ' Inserting picture from address in D column
                                                             ' into column A

            With myPicture ' Setting picture properties
                .ShapeRange.LockAspectRatio = msoTrue ' Keep aspect ratio
                .Height = 100 ' Set your own size
                .Top = Rows(cl.Row).Top
                .Left = Columns(cl.Column).Left
                .Placement = xlMoveAndSize
            End With
            CenterMe ActiveSheet.Shapes(i), cl
            i = i + 1
        End If

    Next    ' Looping to the Nth row, defined in:
            ' " Set Rng = Range("A13:A20") "

    Set myPicture = Nothing

    Application.ScreenUpdating = True

End Sub
Sub CenterMe(Shp As Shape, OverCells As Range)

    With OverCells
        Shp.Left = .Left + ((.Width - Shp.Width) / 2)
        Shp.Top = .Top + ((.Height - Shp.Height) / 2)
    End With
End Sub
Function IsFile(ByVal fName As String) As Boolean
'Returns TRUE if the provided name points to an existing file.
'Returns FALSE if not existing, or if it's a folder
    On Error Resume Next
    IsFile = ((GetAttr(fName) And vbDirectory) <> vbDirectory)
End Function

在excel宏中插入图片，以文件名作为参考

0 个答案: