调整工作表中所有选定图像的大小 [英] Resizing all selected images in a sheet

问题描述

大家好，

我正在尝试调整我根据他们所在的单元格选择的所有选定图像。

<调整大小仍然应该保持比例并调整大小的单元格的最大宽度和高度。

下面是代码，我从一个只调整单个图像的地方看到它一个可以做多个选定图像的。单独
我可以毫无问题地调整图像大小。

当我选择一些图像时出现问题，问题出现了。图像的大小调整似乎是随机发生的，因为我无法找到何时以及为什么某些图像会被调整大小，而其他图像则不知道任何人？

Public Sub FitPic（）

  &NBSP;出错时GoTo NOT_SHAPE

  &NBSP; Dim pic As Picture

  &NBSP; Dim PicWtoHRatio As Single

  &NBSP; Dim CellWtoHRatio As Single

    

  &NBSP;如果TypeName（Selection）=" DrawingObjects"然后

  &NBSP; &NBSP; &NBSP;每张图片在选择中为
  &NBSP; &NBSP; &NBSP; &NBSP; &NBSP; FitIndividualPic pic

  &NBSP; &NBSP; &NBSP;下一张图片
  &NBSP;否则

  &NBSP; &NBSP; &NBSP; FitIndividualPic选择

  &NBSP;结束如果

退出Sub¥
NOT_SHAPE：

  &NBSP; MsgBox"在运行此宏之前选择一张图片。" &安培; "货号" &安培;数¥b $ b    

  End Sub

 

  Public Sub FitIndividualPic（pic as Object）

  &NBSP; Dim Gap As Single

  &NBSP;差距= 3

  &NBSP; &NBSP; &NBSP;用图片
  &NBSP; &NBSP; &NBSP; &NBSP; &NBSP; PicWtoHRatio =（。宽度/。高度）

  &NBSP; &NBSP; &NBSP;结束与$
  &NBSP; &NBSP; &NBSP;使用pic.TopLeftCell

  &NBSP; &NBSP; &NBSP; &NBSP; &NBSP; CellWtoHRatio = .Width / .RowHeight

  &NBSP; &NBSP; &NBSP;结束与$
  &NBSP; &NBSP; &NBSP;选择Case PicWtoHRatio / CellWtoHRatio

  &NBSP; &NBSP; &NBSP;案例是> 1

  &NBSP; &NBSP; &NBSP;用图片
  &NBSP; &NBSP; &NBSP; &NBSP; &NBSP; .Width = .TopLeftCell.Width - Gap

  &NBSP; &NBSP; &NBSP; &NBSP; &NBSP; .Height = .Width / PicWtoHRatio - Gap

  &NBSP; &NBSP; &NBSP;结束与$
  &NBSP; &NBSP; &NBSP; Case Else

  &NBSP; &NBSP; &NBSP;用图片
  &NBSP; &NBSP; &NBSP; &NBSP; &NBSP; .Height = .TopLeftCell.RowHeight - Gap

  &NBSP; &NBSP; &NBSP; &NBSP; &NBSP; .Width = .Height * PicWtoHRatio - Gap

  &NBSP; &NBSP; &NBSP;结束与$
  &NBSP; &NBSP; &NBSP;结束选择

  &NBSP; &NBSP; &NBSP;用图片
  &NBSP; &NBSP; &NBSP; &NBSP; &NBSP; .Top = .TopLeftCell.Top + Gap

  &NBSP; &NBSP; &NBSP; &NBSP; &NBSP; .Left = .TopLeftCell.Left + Gap

  &NBSP; &NBSP; &NBSP;结束时
 结束次级

<

解决方案

在FitPic宏中尝试此操作：

如果TypeName（Selection）=" DrawingObjects"然后
 For Each pic In Selection.ShapeRange 
 FitIndividualPic pic 
下一张pic 
 Else 
 FitIndividualPic选择
结束如果
 

请注意，我将其更改为迭代Selection.ShapeRange而不仅仅是Selection。 我认为这可能会解决您的问题。 我知道你有一个错误处理捕获但如果它是我，我仍然会检查选择的类型是否是"图片"
如果不是"DrawingObjects"对于else子句。

另外，我相信Shape对象有一个名为LockAspectRatio的属性，如果设置为msoTrue，则可以允许您设置新高度或新宽度对象，它会自动计算其他维度以保持宽高比。 
这可能会让您的调整大小计算变得更简单。

我无法测试此代码...我只是想忘记所以请发布回来告诉我这是否有帮助。

Hi All,

I am trying to resize all the selected images that I have selected according to the cell they are in.

the resizing should still keep the proportion and resize to the max width and height of the cell.

below is the code, I took it from somewhere that only does a single image resizing into one that can do multiple selected images.
individually I can resize the image with no problem.
the problem comes when I select a few images, that the issues came out. the resizing of the images seems to occur at random, as I can't find when and why certain image get resized, while the others dont.. any idea anybody?

Public Sub FitPic()

    On Error GoTo NOT_SHAPE
    Dim pic As Picture
    Dim PicWtoHRatio As Single
    Dim CellWtoHRatio As Single
    
    If TypeName(Selection) = "DrawingObjects" Then
        For Each pic In Selection
            FitIndividualPic pic
        Next pic
    Else
        FitIndividualPic Selection
    End If
Exit Sub
NOT_SHAPE:
    MsgBox "Select a picture before running this macro." & " Num" & count
    
 End Sub
 
 Public Sub FitIndividualPic(pic As Object)
    Dim Gap As Single
    Gap = 3
        With pic
            PicWtoHRatio = (.Width / .Height)
        End With
        With pic.TopLeftCell
            CellWtoHRatio = .Width / .RowHeight
        End With
        Select Case PicWtoHRatio / CellWtoHRatio
        Case Is > 1
        With pic
            .Width = .TopLeftCell.Width - Gap
            .Height = .Width / PicWtoHRatio - Gap
        End With
        Case Else
        With pic
            .Height = .TopLeftCell.RowHeight - Gap
            .Width = .Height * PicWtoHRatio - Gap
        End With
        End Select
        With pic
            .Top = .TopLeftCell.Top + Gap
            .Left = .TopLeftCell.Left + Gap
        End With
 End Sub

解决方案

Try this in your FitPic macro:

    If TypeName(Selection) = "DrawingObjects" Then
        For Each pic In Selection.ShapeRange
            FitIndividualPic pic
        Next pic
    Else
        FitIndividualPic Selection
    End If

Notice that I changed it to iterate over Selection.ShapeRange instead of just Selection.  I think that might fix your problem.  I know you have an error handling catch but if it were me, I would still check if the type of the selection is "Picture" if it isn't "DrawingObjects" for the else clause.

Also, I believe that Shape objects have a property named LockAspectRatio that, if set to msoTrue, can allow you to set either the new height OR the new width for the object and it will automatically calculate the other dimension to keep the aspect ratio.  That could make your resizing calculation a little simpler.

I wasn't able to test this code...I'm just going off of what I remember so please post back to let me know if this helped.

这篇关于调整工作表中所有选定图像的大小的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！