IMultiPatch::XYFootprint returns an empty geometry if the multipatch is vertical

If the returned geometry is a polyline, use this code sample.

Code:
Public Sub main()

  Dim pPoly As IPolyline
  Dim pPolyColl As ISegmentCollection
  Dim pLine1 As ILine
  Dim pLine2 As ILine
  Dim pMP As IConstructMultiPatch
  Dim pFootprint As IPolyline
  Dim pTopo As ITopologicalOperator
  Dim pPt0 As IPoint
  Dim pPt1 As IPoint
  Dim pPt2 As IPoint
  Dim pPt3 As IPoint
  Set pPt0 = New Point
  Set pPt1 = New Point
  Set pPt2 = New Point
  Set pPt3 = New Point
  pPt0.PutCoords 0, 0
  pPt1.PutCoords 1, 0
  pPt2.PutCoords 2, 0
  pPt3.PutCoords 3, 3
  Set pMP = New MultiPatch
  Set pLine1 = New Line
  pLine1.PutCoords pPt0, pPt1
  Set pLine2 = New Line
  pLine2.PutCoords pPt2, pPt3
  Set pPolyColl = New Polyline
  pPolyColl.AddSegment pLine1
  pPolyColl.AddSegment pLine2
  Set pPoly = pPolyColl
  Set pTopo = pPoly
  
  pTopo.Simplify
  pMP.ConstructExtrudeFromTo 0, 1, pPoly
  Set pFootprint = FootLine(pMP)

End Sub
Private Function FootLine(pMP As IMultiPatch) As IPolyline
  Dim pResultGeoms As IGeometryCollection
  Dim pResultTopo As ITopologicalOperator
  Dim pStepGeom As IGeometry
  Dim pStepGeoms As IGeometryCollection
  Dim pPartGeom As IGeometry
  Dim pMPGeoms As IGeometryCollection
  Dim cCurrentPart As Long
  Dim cParts
  Set pResultGeoms = New Polyline
  Set pResultTopo = pResultGeoms
  Set pStepGeoms = New Polyline
  Set pStepGeom = pStepGeoms
  Set pMPGeoms = pMP
    
  cParts = pMPGeoms.GeometryCount
  
  For cCurrentPart = 0 To cParts - 1
    MakePartLine cCurrentPart, pMPGeoms, pStepGeom
    Set pPartGeom = pStepGeoms.Geometry(0)
    pResultGeoms.AddGeometry pPartGeom
  Next cCurrentPart

  pResultTopo.Simplify
  Set FootLine = pResultTopo
End Function

Private Sub MakePartLine(cCurrentPart As Long, pMP As IGeometryCollection, pOutGeom As IGeometry)
  Dim cPartPts As Long
  Dim index As Long
  Dim leftX As Double
  Dim leftY As Double
  Dim rightX As Double
  Dim rightY As Double
  Dim x As Double
  Dim y As Double
  Dim pPartGeom As IGeometry
  Dim pPartPts As IPointCollection
  Dim pLeftPt As IPoint
  Dim pRightPt As IPoint
  Dim pCurrentPt As IPoint
  Dim pResultPts As IPointCollection
  Set pPartGeom = pMP.Geometry(cCurrentPart)
  Set pPartPts = pPartGeom
  Set pLeftPt = New Point
  Set pRightPt = New Point
  Set pCurrentPt = New Point
  cPartPts = pPartPts.PointCount
  
  If cPartPts < 1 Then
    pOutGeom.SetEmpty
    Exit Sub
  End If

  pPartPts.QueryPoint 0, pCurrentPt
  pCurrentPt.QueryCoords leftX, leftY
  rightX = leftX
  rightY = leftY
  
  For index = 1 To cPartPts - 1
    pPartPts.QueryPoint index, pCurrentPt
    pCurrentPt.QueryCoords x, y
    If x < leftX Or (x = leftX And y < leftY) Then
      leftX = x
      leftY = y
    ElseIf x > rightX Or (x = rightX And y > rightY) Then
      rightX = x
      rightY = y
    End If
  Next index
  
  pLeftPt.PutCoords leftX, leftY
  pRightPt.PutCoords rightX, rightY
  
  Set pResultPts = pOutGeom
  pOutGeom.SetEmpty
  pResultPts.AddPoint pLeftPt
  pResultPts.AddPoint pRightPt
End Sub