粘贴图像以适应合并的单元格bug

时间:2017-08-30 12:59:57

标签: vba excel-vba excel

我有两个不同的子组件,它们将图像放入合并的单元格中。无论文件大小如何,文件选择方法都会使图像失真以适应合并单元格的高度和宽度。然而,粘贴版本不会同时兼顾宽度和宽度。高度。只有哪一个在编程代码中最后使用。我怎样才能调整我的子粘贴,以便扭曲图像以适应宽度和高度?

Sub FromFile()

    Dim sFileName As String
    Dim oShape As Shape

    If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub

    sFileName = Application.GetOpenFilename( _
        FileFilter:="Images (*.gif;*.jpg;*.png), *.gif;*.jpg;*.png", _
        FilterIndex:=1, _
        Title:="Insert Picture", _
        ButtonText:="Insert", _
        MultiSelect:=False)
    If sFileName = "False" Then Exit Sub

    With ActiveCell.MergeArea
        ActiveSheet.Shapes.AddPicture _
                Filename:=sFileName, _
                LinkToFile:=msoFalse, _
                SaveWithDocument:=msoTrue, _
                Left:=.Left, _
                Top:=.Top, _
                Width:=.Width, _
                Height:=.Height
    End With


End Sub


Public Sub Paste()
Dim p As Picture

    Dim s As Shape, rng As Range
    Set rng = Range("MyMerge")

    For Each s In ActiveSheet.Shapes
        If Intersect(rng, s.TopLeftCell) Is Nothing Then
        Else
            s.Delete
        End If
    Next s

Worksheets("Report").Range("MyMerge").Select
With ActiveCell.MergeArea
    Set p = .Parent.Pictures.Paste
    p.Left = .Left
    p.Top = .Top
    p.Height = .Height
    p.Width = .Width
End With
End Sub

1 个答案:

答案 0 :(得分:0)

添加:

p.Shaperange.lockaspectratio = False

在调整图片大小之前,您应该能够独立地改变高度和宽度。