VBA Else If 语句表现怪异

Question

好的，所以对于 PHP 脚本，我需要将所有非图像对象从 .pptx 文件转换为图像（不包括文本）。由于我有很多 .pptx 文件，我想我还是用 VBA.

然而，出于某种原因，我的 Else If 表现得很奇怪。

Sub nieuwemacro()
    Dim oSl As Slide
    Dim oSh As Shape

    For Each oSl In ActivePresentation.Slides
        For Each oSh In oSl.Shapes

            ' MsgBox (oSh.Type)
            ' modify the following depending on what you want to
            ' convert
            If oSh.Type = 1 Then
                ConvertShapeToPic oSh
            Else
            End If
        Next
    Next
End Sub

Sub ConvertShapeToPic(ByRef oSh As Shape)
    Dim oNewSh As Shape
    Dim oSl As Slide

    oSh.Fill.ForeColor.RGB = RGB(0, 0, 0)

    Set oSl = oSh.Parent
    oSh.Copy
    Set oNewSh = oSl.Shapes.PasteSpecial(ppPastePNG)(1)

    With oNewSh
        .Left = oSh.Left
        .Top = oSh.Top
        Do
            .ZOrder (msoSendBackward)
        Loop Until .ZOrderPosition = .ZOrderPosition
     End With

    oSh.Delete
End Sub

oSh.Fill.ForeColor.RGB = RGB(0, 0, 0) 部分只是为了看看会发生什么。这是结果：

好吧..所以一切都正确转换了，除了那个粉红色的大球。所以我想我会尝试其他一些 Else ifs。我的新 Else If 语句：

If oSh.Type = 1 Then
    ConvertShapeToPic oSh
ElseIf oSh.Type = 14 Then
    ConvertShapeToPic oSh
Else
End If

结果是：

注意到代码现在如何不转换顶部的绿色条了吗？当我添加或删除 IfElse 部件时它会这样做...... 我不知道为什么会这样，有人能告诉我我做错了什么吗？

Answer 1

试试这个

Option Explicit

Sub nieuwemacro()
    Dim oSl As Slide
    Dim oSh As Shape
    Dim oShs() As Shape
    Dim nShps As Long, iShp As Long

    For Each oSl In ActivePresentation.Slides

        ReDim oShs(1 To oSl.Shapes.Count) As Shape
        For Each oSh In oSl.Shapes
            ' MsgBox (oSh.Type)
            ' modify the following depending on what you want to
            ' convert
            If oSh.Type = 1 Then
                nShps = nShps + 1
                Set oShs(nShps) = oSh
            End If
        Next
        If nShps > 0 Then
            For iShp = 1 To nShps
                ConvertShapeToPic oShs(iShp)
            Next iShp
        End If
    Next
End Sub

Sub ConvertShapeToPic(ByRef oSh As Shape)
    Dim oNewSh As Shape
    Dim oSl As Slide

    oSh.Fill.ForeColor.RGB = RGB(0, 0, 0)

    Set oSl = oSh.Parent
    oSh.Copy
    Set oNewSh = oSl.Shapes.PasteSpecial(ppPastePNG)(1)

    With oNewSh
        .Left = oSh.Left
        .Top = oSh.Top
        Do
            .ZOrder (msoSendBackward)
        Loop Until .ZOrderPosition = .ZOrderPosition
     End With

    oSh.Delete
End Sub

您可能还需要考虑以下重构：

Option Explicit

Sub nieuwemacro()
    Dim oSl As Slide
    Dim oShs() As Shape

    For Each oSl In ActivePresentation.Slides
        oShs = GetShapes(oSl, msoAutoShape) '<--| gather shapes of given type and...
        ConvertShapesToPics oShs '<--| ...convert them
    Next
End Sub

Function GetShapes(oSl As Slide, shType As MsoShapeType) As Shape()
    Dim oSh As Shape
    Dim nShps As Long

    With oSl.Shapes '<--| reference passed slide Shapes collection
        ReDim oShs(1 To .Count) As Shape '<--| resize shapes array to referenced slide shapes number (i.e. to maximum possible)
        For Each oSh In .Range '<--| loop through referenced slide shapes
            If oSh.Type = shType Then '<--| if its type matches the passed one
                nShps = nShps + 1 '<--| update gathered shapes counter
                Set oShs(nShps) = oSh '<--| fill gathered shapes array
            End If
        Next
    End With
    If nShps > 0 Then '<--| if any shape has been gathered
        ReDim Preserve oShs(1 To nShps) As Shape '<--| resize array properly ...
        GetShapes = oShs '<--| ... and return it
    End If
End Function

Sub ConvertShapesToPics(oShs() As Shape)
    Dim iShp As Long

    If IsArray(oShs) Then '<--| if array has been initialized ...
        For iShp = 1 To UBound(oShs) '<--|... then loop through its elements (shapes)
            ConvertShapeToPic oShs(iShp) '<--| convert current shape
        Next iShp
    End If
End Sub

Sub ConvertShapeToPic(ByRef oSh As Shape)
    With oSh '<--| reference passed shape
        .Fill.ForeColor.RGB = RGB(0, 0, 0) '<--| change its forecolor
        .Copy '<--| copy it
        With .Parent.Shapes.PasteSpecial(ppPastePNG)(1) '<--| reference pasted shape
            .Left = oSh.Left '<--| adjust its Left position
            .Top = oSh.Top '<--| adjust its Top position
            Do
                .ZOrder (msoSendBackward)
            Loop Until .ZOrderPosition = .ZOrderPosition
        End With
        .Delete '<--| delete referenced passed shape
    End With
End Sub

最后，您可能希望将 "main" sub 缩短两行，更像 follwos

Sub nieuwemacro()
    Dim oSl As Slide

    For Each oSl In ActivePresentation.Slides
        ConvertShapesToPics GetShapes(oSl, msoAutoShape) '<--| convert shapes of given type
    Next
End Sub

其中 GetShapes()、ConvertShapesToPics() 和 ConvertShapeToPic() 保持不变。

VBA Else If 语句表现怪异

VBA Else If statement acting weird

powerpoint

vba

converter