Word宏技术问询：无需调整尺寸获取嵌入OLEObjects原始尺寸的更优方法

这确实是Word VBA里一个挺烦人的坑——Shapes/InlineShapes的缩放属性经常抽风返回0或者无意义的数值，你能想到临时缩放再对比的思路已经很聪明了！不过频繁修改文档尺寸再恢复，不仅可能触发不必要的屏幕刷新影响性能，还存在中途出错导致格式混乱的风险。这里给你分享两种更优的实现思路：

思路1：直接从OLE对象本身获取原始尺寸 #

大部分嵌入的OLE对象（比如Excel工作表、Word文档、图片）都可以通过OLEFormat.Object访问其原始对象模型，直接读取它的原始尺寸属性，完全不需要修改文档内容。

优化后的代码示例 #

处理Shapes中的嵌入OLE对象

For Each shp In ActiveDocument.Shapes
    If shp.Type = msoEmbeddedOLEObject Then
        Dim oleObj As Object
        Set oleObj = shp.OLEFormat.Object
        
        Dim originalW As Double, originalH As Double
        ' 根据OLE对象类型匹配对应的原始尺寸属性
        Select Case TypeName(oleObj)
            Case "Worksheet" ' Excel工作表
                ' 获取已使用区域的尺寸（单位：磅，和Word一致）
                originalW = oleObj.UsedRange.Width
                originalH = oleObj.UsedRange.Height
            Case "Document" ' 嵌入的Word文档
                ' 获取页面可编辑区域的尺寸
                originalW = oleObj.PageSetup.PageWidth - oleObj.PageSetup.LeftMargin - oleObj.PageSetup.RightMargin
                originalH = oleObj.PageSetup.PageHeight - oleObj.PageSetup.TopMargin - oleObj.PageSetup.BottomMargin
            Case "Picture" ' 嵌入的图片类OLE对象
                originalW = oleObj.Width
                originalH = oleObj.Height
            Case Else
                ' 遇到特殊类型OLE对象时， fallback到你的临时方案
                Dim currW As Double, currH As Double
                currW = shp.Width
                currH = shp.Height
                ' 缩放至100%获取原始尺寸
                shp.ScaleWidth 1#, msoTrue
                shp.ScaleHeight 1#, msoTrue
                originalW = shp.Width
                originalH = shp.Height
                ' 恢复原尺寸
                shp.ScaleWidth currW / originalW, msoTrue
                shp.ScaleHeight currH / originalH, msoTrue
        End Select
        
        ' 对比当前尺寸与原始尺寸（允许0.1磅的误差，避免浮点精度问题）
        If Abs(shp.Width - originalW) > 0.1 Or Abs(shp.Height - originalH) > 0.1 Then
            Debug.Print "Shape [" & shp.Name & "] 尺寸异常：当前(" & shp.Width & ", " & shp.Height & ") 原始(" & originalW & ", " & originalH & ")"
        End If
    End If
Next

处理InlineShapes中的嵌入OLE对象

For Each ishp In ActiveDocument.InlineShapes
    If ishp.Type = wdInlineShapeEmbeddedOLEObject Then
        Dim oleInlineObj As Object
        Set oleInlineObj = ishp.OLEFormat.Object
        
        Dim inlineOriginalW As Double, inlineOriginalH As Double
        Select Case TypeName(oleInlineObj)
            Case "Worksheet"
                inlineOriginalW = oleInlineObj.UsedRange.Width
                inlineOriginalH = oleInlineObj.UsedRange.Height
            Case "Document"
                inlineOriginalW = oleInlineObj.PageSetup.PageWidth - oleInlineObj.PageSetup.LeftMargin - oleInlineObj.PageSetup.RightMargin
                inlineOriginalH = oleInlineObj.PageSetup.PageHeight - oleInlineObj.PageSetup.TopMargin - oleInlineObj.PageSetup.BottomMargin
            Case "Picture"
                inlineOriginalW = oleInlineObj.Width
                inlineOriginalH = oleInlineObj.Height
            Case Else
                ' Fallback到临时方案
                Dim currIW As Double, currIH As Double
                currIW = ishp.Width
                currIH = ishp.Height
                ishp.ScaleWidth = 100
                ishp.ScaleHeight = 100
                inlineOriginalW = ishp.Width
                inlineOriginalH = ishp.Height
                ishp.ScaleWidth = (currIW / inlineOriginalW) * 100
                ishp.ScaleHeight = (currIH / inlineOriginalH) * 100
        End Select
        
        If Abs(ishp.Width - inlineOriginalW) > 0.1 Or Abs(ishp.Height - inlineOriginalH) > 0.1 Then
            Debug.Print "InlineShape [" & ishp.Index & "] 尺寸异常：当前(" & ishp.Width & ", " & ishp.Height & ") 原始(" & inlineOriginalW & ", " & inlineOriginalH & ")"
        End If
    End If
Next

思路2：禁用屏幕刷新优化你的原始方案 #

如果遇到某些无法通过OLE对象模型获取尺寸的特殊嵌入对象，你的原始思路依然可行，只需加上屏幕刷新禁用，提升性能并避免视觉闪烁：

Application.ScreenUpdating = False

' 你的原始Shapes循环代码
For Each shp In ActiveDocument.Shapes
    If shp.Type = msoEmbeddedOLEObject Then
        sW = shp.Width
        sH = shp.Height
        shp.ScaleWidth 1#, msoTrue
        shp.ScaleHeight 1#, msoTrue
        sW = sW / shp.Width
        sH = sH / shp.Height
        shp.ScaleWidth sW, msoTrue
        shp.ScaleHeight sH, msoTrue
    End If
Next

' 你的原始InlineShapes循环代码
For Each ishp In ActiveDocument.InlineShapes
    If ishp.Type = wdInlineShapeEmbeddedOLEObject Then
        sW = ishp.Width
        sH = ishp.Height
        ishp.ScaleWidth = 100
        ishp.ScaleHeight = 100
        sW = sW / ishp.Width
        sH = sH / ishp.Height
        ishp.ScaleWidth = sW * 100
        ishp.ScaleHeight = sH * 100
    End If
Next

Application.ScreenUpdating = True

关键注意事项 #

• 单位一致性：Word和大部分OLE对象（如Excel、图片）的尺寸单位都是磅，无需额外转换；如果遇到单位不同的对象，可使用Application.InchesToPoints或Application.CentimetersToPoints进行转换。
• 浮点精度：对比时建议允许微小的误差（比如0.1磅），避免因浮点计算精度问题误判。
• 兼容性：部分特殊OLE对象（比如自定义控件）可能无法通过Object属性访问原始模型，这时候 fallback到你的临时方案是最优选择。

内容的提问来源于stack exchange，提问作者alistairboyer