vba 我需要创建一个 Microsoft Word 宏来自动将图像调整为像素宽度

I need to create a Microsoft Word Macro to automatically resize images to a pixel width

提问by brianmwise

I'm building a macro library for a report set, but in many cases, the images I show as examples in the report need to be resized to one of the following pixel widths:

我正在为报告集构建一个宏库，但在许多情况下，我在报告中作为示例显示的图像需要调整为以下像素宽度之一：

• 300px
• 400px
• 500px
• 600px
• 700px

• 300像素
• 400像素
• 500像素
• 600 像素
• 700 像素

I tried creating a macro that changes the exact width of each image by pixel width, but it seems to ignore the aspect ratio and stretch the image. Is it possible to lock the aspect ratio with a macro?

我尝试创建一个宏，通过像素宽度更改每个图像的确切宽度，但它似乎忽略了纵横比并拉伸了图像。是否可以用宏锁定纵横比？

Realistically all I want is a very short macro that resizes the width of the image by [X] pixels and does nothing else - but, as with any other resize macro, I keep getting the height weirdness.

实际上，我想要的只是一个非常短的宏，它可以将图像的宽度调整 [X] 像素的大小，并且不执行其他任何操作 - 但是，与任何其他调整大小的宏一样，我不断获得高度的怪异。

Is there a resize macro language for ONLY by pixel width?

是否有仅按像素宽度调整大小的宏语言？

---

---

This is the percent sizing code example I've been working from:

这是我一直在使用的百分比大小代码示例：

Sub FNG_setsize75percent()
'
' FNG_setsize75percent Macro
'
'
    Selection.Find.ClearFormatting
    With Selection.Find
        .Text = "^g"
        .Replacement.Text = "^p"
        .Forward = True
        .Wrap = wdFindAsk
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    Dim PercentSize As Integer
     PercentSize = 75
     If Selection.InlineShapes.Count > 0 Then
         Selection.InlineShapes(1).ScaleHeight = PercentSize
         Selection.InlineShapes(1).ScaleWidth = PercentSize
     Else
         Selection.ShapeRange.ScaleHeight Factor:=(PercentSize / 100), _
           RelativeToOriginalSize:=msoCTrue
         Selection.ShapeRange.ScaleWidth Factor:=(PercentSize / 100), _
           RelativeToOriginalSize:=msoCTrue
     End If

    End With
    Selection.InlineShapes(1).LockAspectRatio = msoTrue
End Sub

Now, if I can actually use something similar, my GUESS is that I can use something akin to this:

现在，如果我真的可以使用类似的东西，我的猜测是我可以使用类似的东西：

Sub Img500px
    Selection.InlineShapes(1).LockAspectRatio = msoTrue
    Selection.InlineShapes(1).Width = 375#
    Selection.InlineShapes(1).Height = (Selection.InlineShapes(1).AbsoluteWidth / 375#) * Selection.InlineShapes(1).Height

End Sub

Except for one small problem: It still doesn't work.

除了一个小问题：它仍然不起作用。

Sub Img500px
    With Selection.Find
        .Text = "^g"
        .Replacement.Text = "^p"
        .Forward = True
        .Wrap = wdFindAsk
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
     Selection.InlineShapes(1).Width = 375#
     Selection.InlineShapes(1).Height = (Selection.InlineShapes(1).Width / 375#) * Selection.InlineShapes(1).Height

     End With
     Selection.InlineShapes(1).LockAspectRatio = msoTrue

End Sub

This doesn't work either.

这也行不通。

So while "it's a simple math thing" may seem to fix it, it's still not working as intended.

因此，虽然“这是一个简单的数学问题”似乎可以解决它，但它仍然无法按预期工作。

It's really simple:

这真的很简单：

500 pixels / inches / whatever Lock Aspect Ratio, resize height according to aspect ratio.

500 像素/英寸/任何锁定纵横比，根据纵横比调整高度。

I agree this should be a "simple math problem" but the code still ain't doin' what you sez it's supposed to be doin'.

我同意这应该是一个“简单的数学问题”，但代码仍然没有做你认为它应该做的事情。

Of course I may just go with an external macro program rather than try to futz with this any longer.

当然，我可能只是使用外部宏程序，而不是再尝试使用它。

回答by Tim Williams

You can keep the aspect ratio fixed with a bit of math:

您可以通过一些数学运算来保持纵横比固定：

Sub Tester()
    ResizeWidth Selection.InlineShapes(1), 200
End Sub

Sub ResizeWidth(s, newWidth As Double)
    s.Height = (s.Width / newWidth) * s.Height
    s.Width = newWidth
End Sub

EDIT: this (setting LockAspectRatio) also works for me - the height is automatically adjusted.

编辑：这个（设置 LockAspectRatio）也适用于我 - 高度会自动调整。

Sub ResizeWidth(s, newWidth As Double)
    s.LockAspectRatio = msoTrue
    s.Width = newWidth
End Sub