英文:
In Excel, can a button be created to insert photos into cells without distorting the original image aspect ratio?
问题
为了引言这个问题,我想声明我对代码几乎没有经验。
我正在尝试在Excel电子表格中创建一个按钮,将照片从我的计算机插入到活动单元格中,而不改变单元格的大小或照片的纵横比。照片需要在矩形单元格内居中对齐。不同的图像文件格式也必须被接受。
重要的是要显示原始图像文件而不进行编辑,而不是填充整个单元格。这意味着我希望有一个居中的图像,周围有一些空白空间,即纵向纵横比会在单元格左右留下空白空间,而横向纵横比会在顶部和底部留下空白空间(如果与单元格不完全匹配)。
在Google Sheets中创建的所需格式的示例
我在网上找到了一段代码,它几乎让我得到了我所希望的精确结果,尽管我不能确定它是否是实现这一目标的最佳方法。我可以点击我希望放置照片的单元格,点击插入照片按钮,文件选择将出现供我从计算机中选择照片,然后它将插入图像以填充单元格而不更改单元格大小。
唯一的问题是它会拉伸我的图像以填充活动单元格,而我不能让这些照片以任何方式拉伸。
以下是我VBA项目的代码:
Sub InsertPictureMacro()
Dim strFile As String
Dim rng As Range
Dim sh
Const cFile As String = "Image Files(*.bmp; *.jpg; *.jpeg; *.png; *.tif),"
strFile = Application.GetOpenFilename(filefilter:=cFile, Title:="选择文件")
If strFile = "False" Then
Else
Set rng = ActiveCell.Range("A4").MergeArea
With rng
Set sh = ActiveSheet.Shapes.AddPicture(Filename:=strFile, LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, Left:=.Left, Top:=.Top, Width:=.Width, Height:=.Height)
sh.LockAspectRatio = msoTrue
End With
Set sh = Nothing
Set rng = Nothing
End If
End Sub
以下是我使用的电子表格的图像,单个按钮将固定在前两行。
以下是当前按钮将导致的结果。原始图像被拉伸以适应不同大小的单元格,以填充整个单元格。
英文:
To preface this question, I want to state that I have very little experience with code.
I am trying to create a button inside an Excel spreadsheet to insert photos from my computer into an active cell without changing the size of the cell or the aspect ratio of the photo. The photos need to be centered aligned inside a rectangular cell. Different Image file formats also must be acceptable.
It is more important to have the original image file displaying unedited than having a completely filled cell. That means that I expect to have a centered image surrounded by some blank space inside the cell, i.e. vertical aspect ratios will leave blank space on the left and right of the cell, and horizontal aspect ratios will leave blank space on the top and bottom (if it does not match the the cell exactly).
> Example made in Google Sheets of the formatting I want
I found a code online that got me near the exact result I was hoping for, though I cannot say if it is even the best method of accomplishing this. I can click on the cell I want the photo in, click on the Insert Photo button, the file select will appear for me to grab my photo from my computer, then it inserts the image to fill the cell without the cell size changing.
The only problem is that it stretches my images to fill that active cell, and I cannot have these photos stretched in any way.
Here is the code I have for my VBA project:
Sub InsertPictureMacro()
Dim strFile As String
Dim rng As Range
Dim sh
Const cFile As String = "Image Files(*.bmp; *.jpg; *.jepg; *.png; *.tif),"
strFile = Application.GetOpenFilename(filefilter:=cFile, Title:=Ts)
If strFile = "False" Then
Else
Set rng = ActiveCell.Range("A4").MergeArea
With rng
Set sh = ActiveSheet.Shapes.AddPicture(Filename:=strFile, LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, Left:=.Left, Top:=.Top, Width:=.Width, Height:=.Height)
sh.LockAspectRatio = msoTrue
End With
Set sh = Nothing
Set rng = Nothing
End If
End Sub
> Here is an image of the spreadsheet I am using, the single button will be frozen in the first 2 rows
> Here is what the current button will result in. The original image gets stretched to fit the different sized cells to fill the entire cell
答案1
得分: 0
图像的高度与宽度比例可能不完全匹配单元格的尺寸。关键是计算适当的图像缩小比例,以适应单元格并保持原始宽高比。
Sub InsertPictureMacro()
Dim strFile As String
Dim rng As Range
Dim sh, rw, rh, ratio
Const cFile As String = "图像文件(*.bmp; *.jpg; *.jpeg; *.png; *.tif),"
strFile = Application.GetOpenFilename(filefilter:=cFile, Title:=Ts)
If Not strFile = "False" Then
Set rng = ActiveCell.Range("A4").MergeArea
With rng
' 插入图像
Set sh = ActiveSheet.Pictures.Insert(strFile)
rw = .Width / sh.Width
rh = .Height / sh.Height
' 获取缩小比例,应用0.95以获取周围的空间
ratio = IIf(rw < rh, rw, rh) * 0.95
sh.ShapeRange.LockAspectRatio = msoTrue
sh.Width = sh.Width * ratio
' 将图像定位在中心
sh.Top = .Top + (.Height - sh.Height) / 2
sh.Left = .Left + (.Width - sh.Width) / 2
End With
Set sh = Nothing
Set rng = Nothing
End If
End Sub
英文:
The height-to-width ratio of the image may not match the cell dimensions exactly. The key is to calculate the appropriate image shrink ratio to fit the cell while maintaining the original aspect ratio.
Sub InsertPictureMacro()
Dim strFile As String
Dim rng As Range
Dim sh, rw, rh, ratio
Const cFile As String = "Image Files(*.bmp; *.jpg; *.jepg; *.png; *.tif),"
strFile = Application.GetOpenFilename(filefilter:=cFile, Title:=Ts)
If Not strFile = "False" Then
Set rng = ActiveCell.Range("A4").MergeArea
With rng
' Insert image
Set sh = ActiveSheet.Pictures.Insert(strFile)
rw = .Width / sh.Width
rh = .Height / sh.Height
' Get shrink ratio, apply 0.95 to get surrounded space
ratio = IIf(rw < rh, rw, rh) * 0.95
sh.ShapeRange.LockAspectRatio = msoTrue
sh.Width = sh.Width * ratio
' position image at the center
sh.Top = .Top + (.Height - sh.Height) / 2
sh.Left = .Left + (.Width - sh.Width) / 2
End With
Set sh = Nothing
Set rng = Nothing
End If
End Sub
通过集体智慧和协作来改善编程学习和解决问题的方式。致力于成为全球开发者共同参与的知识库,让每个人都能够通过互相帮助和分享经验来进步。
评论