Contour and break-line intersection points checking

Dear all,

 I have done the program it working fine, but Its very very slow.please guide me to run fast.

Sub Check_InterSect_Contour_BL()
Dim BlE As Element
Dim Bl As LineElement
Dim bls As ShapeElement
Dim conte As Element
Dim Cont As LineElement
Dim enumBL As ElementEnumerator
Dim enumCont As ElementEnumerator
Dim scanBl As ElementScanCriteria
Dim scanCont As ElementScanCriteria
Dim points() As Point3d
Dim Mat As Matrix3d
Dim Zval As Variant
Dim Zval1 As Variant
Dim Zval2 As Variant
Mat = Matrix3dIdentity
Set scanBl = New ElementScanCriteria
Set scanCont = New ElementScanCriteria
Dim cir As EllipseElement
Dim chlvlstr As String
Dim chlevel As Level
Dim olevel As Level

chlvlstr = "Error"
Set chlevel = ActiveModelReference.Levels.Find(chlvlstr)
If chlevel Is Nothing Then
Set chlevel = ActiveDesignFile.AddNewLevel(chlvlstr)
Else
End If

scanBl.ExcludeAllLevels
scanBl.IncludeLevel ActiveDesignFile.Levels("Breakline")
scanCont.ExcludeAllLevels
scanCont.IncludeLevel ActiveDesignFile.Levels("Contour")
scanCont.IncludeLevel ActiveDesignFile.Levels("Contour_ma")


Set enumBL = ActiveModelReference.Scan(scanBl)



Do While enumBL.MoveNext
    Set BlE = enumBL.Current
        If BlE.IsLineElement Then
        Set Bl = enumBL.Current
        Set enumCont = ActiveModelReference.Scan(scanCont)

        Do While enumCont.MoveNext
          Set conte = enumCont.Current
           If conte.IsLineElement Then
           Set Cont = enumCont.Current
               Zval1 = Cont.StartPoint.Z
                
                If Bl.IsIntersectableElement Then
                   points = Bl.AsIntersectableElement.GetIntersectionPoints(Cont, Mat)
                End If
                
                For t = 0 To UBound(points)
                Zval2 = points(t).Z
                Zval = Zval1 - Zval2
                If Zval > 0.3 Then
                Set cir = CreateEllipseElement2(Nothing, points(t), 5, 5, Mat)
                ActiveModelReference.AddElement cir
                cir.Level = chlevel
                cir.Rewrite
                cir.Redraw
                End If
                
                Next
                   
            Else
                MsgBox "plase drop other type to linestring"
            End If
    
        Loop
        
        ElseIf BlE.IsShapeElement Then
        Set bls = enumBL.Current
        Set enumCont = ActiveModelReference.Scan(scanCont)
        enumCont.BuildArrayFromContents
        enumCont.Reset
        Do While enumCont.MoveNext
          Set conte = enumCont.Current
           If conte.IsLineElement Then
           Set Cont = enumCont.Current
               Zval1 = Cont.StartPoint.Z
                
                If Bl.IsIntersectableElement Then
                   points = bls.AsIntersectableElement.GetIntersectionPoints(Cont, Mat)
                End If
                
                For t = 0 To UBound(points)
                Zval2 = points(t).Z
                Zval = Zval1 - Zval2
                If Zval > 0.1 Then
                Set cir = CreateEllipseElement2(Nothing, points(t), 5, 5, Mat)
                ActiveModelReference.AddElement cir
                cir.Level = chlevel
                cir.Rewrite
                cir.Redraw
                End If
                Next
            Else
                MsgBox "plase drop other type to linestring"
            End If
    
        Loop
                   
        Else
            MsgBox "plase drop other type to linestring"
               
        End If
Loop
End Sub