Question

我一直在研究这个代码，我需要从PC上输入图像，将它们粘贴到某个列中，然后根据图像大小调整单元格的大小。以下是我正在使用的代码：

Sub BBS()
Dim file As Variant
Dim r As Integer
Dim ID As Integer
 For r = 1 To 6
  ID = Cells(r, 1).Value
  file = "D:\" & ID & ".jpg"
  If Dir(file) = "" Then

  Else
  With ActiveSheet.Pictures.Insert(file)
    .Left = ActiveSheet.Cells(r, 5).Left
    .Top = ActiveSheet.Cells(r, 5).Top
  End With
  End If
  Next r

Call Resize

End Sub

Sub Resize()

 Worksheets("Sheet1").Columns("A:I").AutoFit
 Worksheets("Sheet1").Rows("1:10").AutoFit
End Sub

图像被粘贴，但我无法调整单元格大小。

Answer 1

那是因为图片不是在单元格中 - 它只是放在单元格位置的工作表中。

尝试使用Excel本身（而不是VBA窗口）。您实际上是插入一张图片，移动它以使其与单元格的左上角坐标匹配，然后尝试自动调整。（细胞不会发生任何事情）。

你可以捏造＆＃39;通过使用以下方法设置图片大小：

Sub BBS()

    Dim file As Variant
    Dim r As Integer
    Dim ID As Integer

    For r = 1 To 6
        ID = Cells(r, 1).Value
        file = "D:\" & ID & ".jpg"
        If Not Dir(file) = "" Then

        With ActiveSheet.
            .AddPicture file, msoFalse, msoTrue, _
             ActiveSheet.Cells(r, 5).Left, ActiveSheet.Cells(r, 5).Top, 100, 100
        End With

        End If
    Next r

    Call Resize

End Sub

Sub Resize()

    Worksheets("Sheet1").Columns("A:I").ColumnWidth = 18.29
    Worksheets("Sheet1").Rows("1:10").RowHeight = 100

End Sub

请注意.AddPicture和ColumnWidth / RowHeight使用的比例不同。你必须在这里试验。

<强>更新

Sub BBS()

    Dim r As Integer
    Dim ID As Integer
    Dim ws As Worksheet

    Dim objShell As New Shell
    Dim objFolder As Folder
    Dim objFile As ShellFolderItem

    Dim strDimensions As String
    Dim intPos As Integer 'Position of first space in strDimensions
    Dim intWidth As Integer
    Dim intHeight As Integer
    Dim intWidthMax As Integer

    Set objFolder = objShell.Namespace("D:\")

    Set ws = ActiveSheet

    intWidthMax = 0

    For r = 1 To 3
       ID = Cells(r, 1).Value

       Set objFile = objFolder.ParseName(ID & ".jpg")

       strDimensions = objFile.ExtendedProperty("Dimensions")

       intPos = InStr(1, strDimensions, " ", vbTextCompare)

       'These next variables contain the dimensions of the image in pixels.
       intWidth = CInt(Mid(strDimensions, 2, intPos - 2))
       intHeight = CInt(Mid(strDimensions, intPos + 3, Len(strDimensions) - intPos - 3))

       With ActiveSheet.Shapes
          'Here we treat the dimension values (which are actually in pixels) as points.
          'The conversions depend on your DPI, so you could play around with a scaling
          'factor here.
          .AddPicture objFile.Path, msoFalse, msoTrue, ActiveSheet.Cells(r, 5).Left, _
           ActiveSheet.Cells(r, 5).Top, intWidth, intHeight
        End With

       'RowHeight is done in points, so it will match the height of your images.
       ws.Rows(r).RowHeight = intHeight

       If intWidth > intWidthMax Then intWidthMax = intWidth

   Next r

    'Set column width to widest image width.
    'Width points are different from height points.
    '5.29 as a conversion works for me (and my DPI).
    ws.Columns(5).ColumnWidth = intWidthMax / 5.29

End Sub

粘贴图像后自动调整单元格大小（行和列）

1 个答案: