[已解决]vba 循环插入图片异常

scz467 · 发表于 2013-2-19 17:59

Sub insertPic()
'
'删除已有图片
Dim S1 As Shape
'Dim RG As Range
For Each S1 In ActiveSheet.Shapes
If S1.Type <> 8 Then
S1.Delete
End If
Next S1
'插入图片
imgWidth = InputBox("请输入一个 0～1 之间的小数(不包括 0 和 1)", "设置插入图片列的宽度", 0)
imgHeight = InputBox("请输入一个 0～1 之间的小数(不包括 0 和 1)", "设置插入图片行的高度", 0)
hColumn = InputBox("请输入插入的列数", "设置插入图片行的高度", 0)
If IsNumeric(hColumn) = True And imgWidth < 1 And imgWidth > 0 And imgHeight < 1 And imgHeight > 0 Then
Dim i As Integer
Dim FilPath As String
Dim rng As Range
Dim S As String
With Sheet1
For i = 2 To .Range("a65536").End(xlUp).Row
FilPath = ThisWorkbook.Path & "\photos" & .Cells(i, 1).Text & ".jpg"
'FilPath = "D:\vba\vbatest\photos" & .Cells(i, 1).Text & ".jpg"
If Dir(FilPath) <> "" Then
.Pictures.Insert(FilPath).Select
MsgBox hColumn
Set rng = .Cells(i, hColumn)
With Selection
ActiveSheet.Rows(i).RowHeight = Selection.ShapeRange.Height * imgHeight '调整行高适合图片大小 Selection.ShapeRange.Height
ActiveSheet.Columns(Column).ColumnWidth = Selection.ShapeRange.Width * imgWidth * 0.2 '粗略调整列宽适合图片大小 Selection.ShapeRange.Width * lWidth
.Top = rng.Top + 1
.Left = rng.Left + 2
.Width = rng.Width
.Height = rng.Height
End With
Else
S = S & Chr(10) & .Cells(i, 1).Text
End If
Next
.Cells(hColumn, i).Select
End With
If S <> "" Then
MsgBox S & Chr(10) & "没有照片"
End If
Else
MsgBox "输入有误"
End If
End Sub