excel 使用宏vba插入图片以适应合并单元格或单个单元格

k4emjkb1 于 2022-12-05 发布在其他

关注(0)|答案(2)|浏览(617)

我在将InsertPicture代码集成到FitPicture宏中时遇到了问题。我对如何在使用Insert函数后自动调整形状大小感到困惑。它给了我关于对象的错误。这是我研究的想法的a link，但仍然无法实现。感谢您的帮助。谢谢。
下面是我用来将图片调整到合并单元格或单个单元格中的宏：

Sub FitPicture()
On Error GoTo NOT_SHAPE
Dim r As Range, sel As Shape
Set sel = ActiveSheet.Shapes(Selection.Name)
sel.LockAspectRatio = msoTrue
Set r = Range(sel.TopLeftCell.MergeArea.Address)

Select Case (r.Width / r.Height) / (sel.Width / sel.Height)
Case Is > 1
    sel.Height = r.Height * 0.9
Case Else
    sel.Width = r.Width * 0.9
End Select

sel.Top = r.Top + 0.05 * sel.Height: sel.Left = r.Left + 0.05 * sel.Width

Exit Sub
NOT_SHAPE:
MsgBox "Please select a picture first."
End Sub

下面是我用来插入图片的宏：

Sub InsertPicture()
Dim sPicture As String, pic As Picture

sPicture = Application.GetOpenFilename _
("Pictures (*.gif; *.jpg; *.bmp; *.tif), *.gif; *.jpg; *.bmp; *.tif", _
, "Select Picture to Import")

If sPicture = "False" Then Exit Sub

Set pic = ActiveSheet.Pictures.Insert(sPicture)
With pic
.ShapeRange.LockAspectRatio = msoFalse
.Height = ActiveCell.Height
.Width = ActiveCell.Width
.Top = ActiveCell.Top
.Left = ActiveCell.Left
.Placement = xlMoveAndSize
End With

Set pic = Nothing

End Sub

我如何将我的FitPicture代码集成到InsertPicture代码中？我需要在插入后自动调整大小，使用我在FitPicture上提到的修改。顺便说一句，我使用的是Excel 2013。谢谢伙伴们。

excel

来源：https://stackoverflow.com/questions/47069675/inserting-picture-using-macro-vba-to-adopt-to-a-merged-cell-or-single-cell

2条答案

按热度按时间

qlvxas9a1#

经过一天的尝试，我完成了宏。工作在单个单元格，合并单元格或选定的单元格，甚至没有合并。

Sub Insert()

Dim myPicture As String, MyRange As Range
myPicture = Application.GetOpenFilename _
("Pictures (.bmp; .gif; .jpg; .png; .tif),.bmp; .gif; .jpg; .png; .tif", _
, "Select Picture to Import")

Set MyRange = Selection
InsertAndSizePic MyRange, myPicture
End Sub

Sub InsertAndSizePic(Target As Range, PicPath As String)

Dim p As Picture
Application.ScreenUpdating = False

On Error GoTo EndOfSubroutine:
Set p = ActiveSheet.Pictures.Insert(PicPath)

'resize
Select Case (Target.Width / Target.Height) / (p.Width / p.Height)
Case Is > 1
p.Height = Target.Height * 0.9
Case Else
p.Width = Target.Width * 0.9
End Select

'center picture
p.Top = Target.Top + (Target.Height - p.Height) / 2: p.Left = Target.Left + 
(Target.Width - p.Width) / 2

Exit Sub

EndOfSubroutine:
End Sub

赞(0）回复(0）举报 2022-12-05

lf5gs5x22#

非常感谢您的支持。在VBA窗口中测试时，我能够让它工作，但是当我尝试使用该文件时，它现在给出了以下错误：
无法运行宏“Blank Formula Template. xlsm '！InsertPhotoMacro”。该宏可能在此工作簿中不可用，或者所有宏都被禁用。

赞(0）回复(0）举报 2022-12-05