英文:
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; *.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
这是我正在使用的电子表格的图片,单个按钮将固定在前两行:
这是当前按钮的效果。原始图像被拉伸以适应不同大小的单元格,以填充整个单元格:
英文:
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; *.jepg; *.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
通过集体智慧和协作来改善编程学习和解决问题的方式。致力于成为全球开发者共同参与的知识库,让每个人都能够通过互相帮助和分享经验来进步。
评论