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

我一直在处理这个代码，我需要从我的电脑input图像，将它们粘贴到某一列，然后根据图像大小调整单元格大小。 以下是我正在使用的代码：

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窗口）。 你基本上插入一个图片，移动它，以便它匹配单元格的左上坐标，然后尝试AutoFit。 （没有什么会发生在细胞）。

你可以通过使用这个设置图片的大小来“捏造”它：

 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使用的.AddPicture不相同。 你必须在这里试验。

---

更新

 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