Question

我正在尝试用Excel 2013中的VBA帮助同事。看起来宏已成功从指定路径中提取图像，但它会将每张照片转储到单元格A1中。

有什么想法吗？

Sub DeleteAllPictures()
   Dim S As Shape
   For Each S In ActiveSheet.Shapes
     Select Case S.Type
       Case msoLinkedPicture, msoPicture
         S.Delete
     End Select
   Next
 End Sub

Sub UpdatePictures()
   Dim R As Range
   Dim S As Shape
   Dim Path As String, FName As String

  'Setup the path
   Path = "G:\In Transit\Carlos\BC Website images"
   'You can read this value also from a cell, e.g.:
   'Path = Worksheets("Setup").Range("B1")

  'Be sure the path has a trailing backslash
   If Right(Path, 1) <> "\" Then Path = Path & "\"

  'Visit each used cell in column A
   For Each R In Range("B1", Range("B" & Rows.Count).End(xlUp))
     'Try to get the shape
     Set S = GetShapeByName(R)
     'Found?
     If S Is Nothing Then
       'Find the picture e.g. "C:\temp\F500.*"
       FName = Dir(Path & R & ".*")
       'Found?
       If FName <> "" Then
         Set S = InsertPicturePrim(Path & FName, R)
       End If
     End If
     If Not S Is Nothing Then
       'Show the error if the name did not match the cell
       If S.Name <> R Then R.Interior.Color = vbRed
       With R.Offset(0, 1)
         'Move the picture to the cell on the right side
         S.Top = .Top
         S.Left = .Left
         'Resize it
         S.Width = .Width

        'Remove the aspect ratio by default if necessary
         'S.LockAspectRatio = False

        If S.LockAspectRatio Then
           'Make it smaller to fit the cell if necessary
           If S.Height > .Height Then S.Height = .Height
         Else
           'Stretch the picture
           S.Height = .Height
         End If
       End With
       'Move it behind anything else
       S.ZOrder msoSendToBack
     Else
       R.Offset(0, 1) = "No picture available"
     End If
   Next
 End Sub

Private Function GetShapeByName(ByVal SName As String) As Shape
   'Return the shape with SName, Nothing if not exists
   On Error Resume Next
   Set GetShapeByName = ActiveSheet.Shapes(SName)
 End Function

Private Function InsertPicturePrim(ByVal FName As String, ByVal SName As String) As Shape
   'Inserts the picture, return the shape, Nothing if failed
   Dim P As Picture
   On Error Resume Next
   'Insert the picture
   Set P = ActiveSheet.Pictures.Insert(FName)
   'code to resize
    With P
    .ShapeRange.LockAspectRatio = msoFalse
    .Height = ActiveCell.Height
    .Width = ActiveCell.Width
    .Top = ActiveCell.Top
    .Left = ActiveCell.Left
    .Placement = xlMoveAndSize
   End With
   Set P = Nothing

'code to resize

   'Success?
   If Not P Is Nothing Then
     'Return the shape
     Set InsertPicturePrim = P.ShapeRange(1)
     'Rename it, so we can easily find it later
     P.Name = SName
   End If
 End Function

Answer 1

简短的回答是：您的宏将图片插入所选单元格。在插入行之前更改选择，您应该在每行插入它。

在这个示例中，我选择要从中提取名称值的单元格左侧的单元格。

   If FName <> "" Then
     'select the cell 1 to the left of the cell containing the image name
     R.Offset(0,-1).select
     Set S = InsertPicturePrim(Path & FName, R)
   End If

Excel错误地放置图像

1 个答案: