[已解决]求助用vb代码插入图片后的显示位置

有你才幸福

哪位老师来帮忙解答下

最佳答案

月排行榜 / 总排行榜

zjdh

2016-8-11 14:59

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address <> "$C$3" Then Exit Sub
    On Error Resume Next
    Application.EnableEvents = False
    Pictures(1).Delete
    With Range("k3").MergeArea
        Pictures.Insert ThisWorkbook.Path & "\照片\" & Range("C3") & ".jpg"
        Pictures(1).ShapeRange.LockAspectRatio = msoFalse
        Pictures(1).Height = .Height
        Pictures(1).Width = .Width
        Pictures(1).Left = .Left
        Pictures(1).Top = .Top
    End With
    Application.EnableEvents = True
End Sub

跳转到最佳答案楼层

qqyyh

可以呀！试过了

爱疯

Private Sub Worksheet_Change(ByVal Target As Range)
   If Target.Address = "$C$3" Then Call addPic
End Sub

Sub addPic()
    Dim p As String
    Dim f As String
    Dim shp As Shape

    Sheets("Sheet1").Select
    ActiveSheet.Pictures.Delete
    p = ThisWorkbook.Path & "\照片\"
    f = [c3] & ".jpg"

    With [k3].MergeArea
        Set shp = ActiveSheet.Shapes.AddPicture(Filename:=p & f, _
        LinkToFile:=msoTrue, SaveWithDocument:=False, _
        Left:=.Left, Top:=.Top, Width:=.Width, Height:=.Height)
    End With
End Sub

求助插入图片显示位置2.rar (193.25 KB, 下载次数: 29)

2016-8-11 14:45 上传

点击文件名下载附件




楼主用的是excel2007吗？

在07中，Pictures.Insert 方法对于本地图片，默认插到Left=50，Top=50。

zjdh

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address <> "$C$3" Then Exit Sub
    On Error Resume Next
    Application.EnableEvents = False
    Pictures(1).Delete
    With Range("k3").MergeArea
        Pictures.Insert ThisWorkbook.Path & "\照片\" & Range("C3") & ".jpg"
        Pictures(1).ShapeRange.LockAspectRatio = msoFalse
        Pictures(1).Height = .Height
        Pictures(1).Width = .Width
        Pictures(1).Left = .Left
        Pictures(1).Top = .Top
    End With
    Application.EnableEvents = True
End Sub

有你才幸福

谢谢老师，学习了。

有你才幸福

爱疯 发表于 2016-8-11 14:48
Private Sub Worksheet_Change(ByVal Target As Range)
   If Target.Address = "$C$3" Then Call addPic
...

是的，哦，原来如此啊，以前是用2010的这个代码可以用，最近重新做了系统用的2007，就不灵了，原来是这样啊，受教了。

有你才幸福

zjdh 发表于 2016-8-11 14:59
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address  "$C$3" Then Exit Sub
   ...

老师另外问你下插入表单控件里面的；按钮（窗体控件）这个能改变颜色样式吗？太难看了，用ActiveX按钮好看但是，删除图片的时候，按钮也被删除了。

zjdh

以下语句就只删除图片啦
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address <> "$C$3" Then Exit Sub
    For Each SP In ActiveSheet.Shapes
        If SP.Type = 13 Then SP.Delete
    Next
    Set RM = Range("k3").MergeArea
    With Pictures.Insert(ThisWorkbook.Path & "\照片\" & Range("C3") & ".jpg").ShapeRange
        .LockAspectRatio = msoFalse
        .Height = RM.Height
        .Width = RM.Width
        .Left = RM.Left
        .Top = RM.Top
    End With
End Sub