|
|
Private Sub Worksheet_Change(ByVal Target As Range)
Dim strPath$, strFileName$, strExtName$, dic As Object
If Target.Count > 1 Then Exit Sub
If Target.Row = 1 Then Exit Sub
If Target.Column = 2 Then
Set dic = CreateObject("Scripting.Dictionary")
strPath = ThisWorkbook.Path & "\图片\"
With CreateObject("VBScript.RegExp")
.Pattern = "jpg|jpep|png|gif|bmp|gif"
.IgnoreCase = True
strFileName = Dir(strPath & "*.*")
Do Until strFileName = ""
strExtName = Mid(strFileName, InStrRev(strFileName, ".") + 1)
If .test(strExtName) Then
dic(Left(strFileName, InStrRev(strFileName, ".") - 1)) = strPath & strFileName
End If
strFileName = Dir
Loop
End With
If dic.exists(Target.Value) Then
Target.Offset(, 1).Select
Call CelPicDel(ActiveCell)
With ActiveSheet.Pictures.Insert(dic(Target.Value)).Select
With Selection
.ShapeRange.LockAspectRatio = msoFalse
.Height = ActiveCell.Height
.Width = ActiveCell.Width
End With
End With
End If
End If
End Sub
Function CelPicDel(Rng As Range)
Dim shp As Shape
For Each shp In Rng.Parent.Shapes
If shp.Type = msoPicture Then
If Abs((shp.Left + shp.Width / 2) - (Rng.Left + Rng.Width / 2)) < (shp.Width + Rng.Width) / 2 And _
Abs((shp.Top + shp.Height / 2) - (Rng.Top + Rng.Height / 2)) < (shp.Height + Rng.Height) / 2 Then
shp.Delete
End If
End If
Next
End Function
|
评分
-
1
查看全部评分
-
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2024-5-2 15:45
怎样在下图的效果，B列输入号码，C列显示图片
楼主
