VBA - 在 Word 文档中旋转 Word.Shapes

Question

这是我的问题。我需要在单个 Word 文档中旋转 Word.Shapes，但我的脚本只会旋转第一个，我不知道为什么。

Word 文档是这样产生的（打开每页一个形状的 PDF）：

Set wrdDoc = wrdAppMain.Documents.Open(FileName:=sToSaveAs, Visible:=False)

以下是循环的设计方式：

For Each wrdShape In wrdDoc.Shapes

    If CheckFormat(wrdShape) = False Then
        FitToPage = False
        GoTo ExitScript
    End If

Next wrdShape

现在正在起作用的部分：

Private Function CheckFormat(oShapeToCheck As Word.Shape) As Boolean

    On Error GoTo Failed

    Dim siAspectRatio As Single
    Dim iRotation As Integer

     '---- Seitenverhältnis und Rotation berechnen ----
     If oShapeToCheck.Height > 0 And oShapeToCheck.Width > 0 Then
        siAspectRatio = oShapeToCheck.Height / oShapeToCheck.Width
        iRotation = oShapeToCheck.Rotation
     Else
        ErrorCode = " (PDF)"
        GoTo Failed
     End If

     '---- Kontrolle ob Bild im Querformat vorliegt ----
     If siAspectRatio < 1 Then

     '---- Kontrolle ob rotiert oder natives Querformat ----
     Select Case iRotation
         Case 0
             oShapeToCheck.IncrementRotation 90
         Case 180
             oShapeToCheck.IncrementRotation 270
         Case 90
             oShapeToCheck.IncrementRotation 0
         Case 270
             oShapeToCheck.IncrementRotation 180
     End Select

所以问题就在这里。虽然我将旋转第一个符合条件的 Word.Shape，但其他任何一个都不会。此外，如果我在脚本执行旋转之前将 Word-Document 的可见性设置为 TRUE、调试并全屏显示 Word-Document，它每次都会旋转任何 Word.Shape。

我尝试过使用 .Activate 之类的东西，但似乎没有任何效果。希望你能帮助我！

谢谢！

马库斯

Answer 1

所以我找到了一种方法来完成这项工作。我不是单独旋转每个 Word.Shape，而是通过它们的索引（或那个索引上的任何复数）将它们全部收集在一个 ShapeRange 中，然后一次旋转它们。

Select Case iRotation
        Case 0
            If bIsDimensioned = False Then
                ReDim Preserve RotationArray(0 To 0) As Variant
                RotationArray(0) = iShapeIndex
                bIsDimensioned = True
            Else
                ReDim Preserve RotationArray(0 To UBound(RotationArray) + 1) As Variant
                RotationArray(UBound(RotationArray)) = iShapeIndex
            End If
End Select

在 ShapeRange 完全填充后：

If bIsDimensioned = True Then
    Set RotationShapeRange = wrdDoc.Shapes.Range(RotationArray)
    RotationShapeRange.IncrementRotation 90
    RotationShapeRange.WrapFormat.Type = wdWrapTight
    RotationShapeRange.RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
    RotationShapeRange.RelativeVerticalPosition = wdRelativeVerticalPositionPage
    RotationShapeRange.Left = wdShapeCenter
    RotationShapeRange.Top = wdShapeCenter
End If

应该是这样的！

Answer 2

令人沮丧的是，新代码在损坏的部分中重新粘贴 - 无法开始工作。