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）の部分は何が起こるかを見るためにだけ存在します。そして、これが結果です：

よし...だから、すべてのものは、大きなピンクのボールを除き、適切に変換されます。だから私は他のいくつかのifsを試してみると思った。私の新しいエルスif文：

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

この中で結果として得られる：コードが今一番上にある緑色のバーを変換doesntの方法

お知らせ？ 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 

最後に、あなたがより多くのような二行の「メイン」サブを下に短縮することができますフォローズ

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()は同じままです。