[已解决]求高手写个代码

A微微笑 · 发表于 2016-12-15 11:02

求助高手解决，我想在这个表里在任一单元格上写上字，然后在这个单元格上自动更新这个文字的图片，图片大小按单元格的大小高小0.1CM长按原图比例调整，如图（即实现我输入爸在这个单元格上自动更新爸的图片，输入爸的笔顺在这个单元格上自动更新出爸的笔顺图： QQ图片20161215113202.png

最佳答案

苏子龙

2016-12-23 22:17

Private Sub Worksheet_Change(ByVal T As Range)
If T.Count > 1 Or T.Column > 1 Then Exit Sub '当单元格不满足时退出
Dim mypath$, i&, pic As Shape, picH, shp As Shape
On Error Resume Next
For Each pic In Sheet1.Shapes '删除原来单元格图片
If pic.Name = T.Address Or pic.Name = T.Offset(0, 4).Address & "bs" Then pic.Delete
Next
mapath = ThisWorkbook.Path & "\文字库" '图片所在文件夹路径
If T.Value <> "" And Dir(mapath & T.Value & ".jpg") <> "" Then '插入jpg文字图片
Sheet1.Shapes.AddPicture(mapath & T.Value & ".jpg", True, True, T.Left + 1, T.Top + 1, T.Width - 2, T.Height * 2 - 2).Select
Selection.Name = T.Address
With T.Offset(0, 4) '插入笔顺的单元格插入笔顺图片
If Dir(mapath & T.Value & "的笔顺.png") <> "" Then
Sheet1.Shapes.AddPicture mapath & T.Value & "的笔顺.png", True, True, .Left, .Top, -1, -1
ElseIf Dir(mapath & T.Value & "的笔顺.jpg") <> "" Then
Sheet1.Shapes.AddPicture mapath & T.Value & "的笔顺.jpg", True, True, .Left, .Top, -1, -1
End If
Set shp = ActiveSheet.Shapes(ActiveSheet.Shapes.Count) '设定图片大小（宽度总大于高的，故用高度确定图片高度）
shp.Left = .Left + 2 '尺寸不对可以改下下面几个数字参数
shp.Top = .Top + 2
picH = .Height / shp.Height * 0.9
shp.ScaleWidth picH, msoFalse, msoScaleFromTopLeft
shp.Name = .Address & "bs"
End With
End If
T.Offset(1).Select
End Sub

复制代码

A微微笑 · 发表于 2016-12-15 12:34

求高手帮解决

苏子龙 · 发表于 2016-12-15 12:38

Sub 插入图片()
Dim rg As Range, mypath$, pic As Shape, i&
Dim endRow&, sh As Worksheet
On Error Resume Next
endRow = [a65536].End(3).Row
Set sh = Worksheets("sheet1")
Call 删除图片
mapath = ThisWorkbook.Path & "\文字库"
For i = 1 To endRow Step 2
Set rg = Range("a" & i)
sh.Shapes.AddPicture mapath & rg.Value & ".jpg", True, True, rg.Left + 1, rg.Top + 1, rg.Width - 2, rg.Height * 2 - 2
With rg.Offset(0, 4)
If Dir(mapath & rg.Value & "的笔顺.png") <> "" Then
sh.Shapes.AddPicture mapath & rg.Value & "的笔顺.png", True, True, .Left, .Top, .Width, .Height
ElseIf Dir(mapath & rg.Value & "的笔顺.jpg") <> "" Then
sh.Shapes.AddPicture mapath & rg.Value & "的笔顺.jpg", True, True, .Left, .Top, .Width, .Height
End If
End With
Next
End Sub
Sub 删除图片()
For Each pic In ActiveSheet.Shapes
If pic.Type = 11 Then pic.Delete
Next
End Sub

复制代码

A微微笑 · 发表于 2016-12-15 12:45

苏子龙发表于 2016-12-15 12:38

可以不要有按钮，输入字，自动插入，删除字就自动删除图片，不用点按钮更新吗？？

苏子龙 · 发表于 2016-12-15 13:26

A微微笑发表于 2016-12-15 12:45
可以不要有按钮，输入字，自动插入，删除字就自动删除图片，不用点按钮更新吗？？

已改，看下效果

Private Sub Worksheet_Change(ByVal T As Range)
If T.Count > 1 Then Exit Sub
Dim mypath$, i&, pic As Shape
On Error Resume Next
mapath = ThisWorkbook.Path & "\文字库"
If T.Value <> "" And Dir(mapath & T.Value & ".jpg") <> "" Then
Sheet1.Shapes.AddPicture(mapath & T.Value & ".jpg", True, True, T.Left + 1, T.Top + 1, T.Width - 2, T.Height * 2 - 2).Select
Selection.Name = T.Address
With T.Offset(0, 4)
If Dir(mapath & T.Value & "的笔顺.png") <> "" Then
Sheet1.Shapes.AddPicture(mapath & T.Value & "的笔顺.png", True, True, .Left, .Top, .Width, .Height).Select
Selection.Name = T.Address & "bs"
ElseIf Dir(mapath & T.Value & "的笔顺.jpg") <> "" Then
Sheet1.Shapes.AddPicture(mapath & T.Value & "的笔顺.jpg", True, True, .Left, .Top, .Width, .Height).Select
Selection.Name = T.Address & "bs"
End If
End With
ElseIf T.Value = "" Then
For Each pic In Sheet1.Shapes
If pic.Name = T.Address Or pic.Name = T.Address & "bs" Then pic.Delete
Next
End If
T.Offset(1).Select
End Sub

复制代码

A微微笑 · 发表于 2016-12-15 13:38

苏子龙发表于 2016-12-15 13:26
已改，看下效果

下载了，用不了的

苏子龙 · 发表于 2016-12-15 14:08

A微微笑发表于 2016-12-15 13:38
下载了，用不了的

宏要启用的，文件-选项-信任中心-信任中心设置-宏设置-启用所有宏（或者禁用所有宏，并发出通知）

A微微笑 · 发表于 2016-12-23 13:48

苏子龙发表于 2016-12-15 14:08
宏要启用的，文件-选项-信任中心-信任中心设置-宏设置-启用所有宏（或者禁用所有宏，并发出通知）

亲，不知道为什么？还是不行哦，能帮再改改吗？？

A微微笑 · 发表于 2016-12-23 13:53

苏子龙发表于 2016-12-15 14:08
宏要启用的，文件-选项-信任中心-信任中心设置-宏设置-启用所有宏（或者禁用所有宏，并发出通知）

大神，还是不行啊，能帮再改一下吗？？

苏子龙 · 发表于 2016-12-23 15:46

请看动画，图片文件夹，要和excel文件放在同一路径下

		自动登录	找回密码
密码			注册