'#Reference {F64FEA84-AF63-11D0-81CE-444553540000}#1.0#0#SUCCESSDB.DLL#US Cost SuccessDB Object Library v1.0
Sub Main()
'
'
' DetailItemAssignments_DeleteZeroCost
'
' This macro will delete any Detail Item Assignments from the active tree of 
' the active project, that contain a zero cost.
'
' Version 1.0 (9-23-1999)
'
' Copyright (C)1990-1999 By U.S. COST, Inc.
'
' Permission to use, copy, modify, and distribute this software for any purposes
' without fee is hereby granted, provided that the above copyright notice appears
' in all copies and that both the copyright notice and the limited warranty and
' restricted rights notice below appear in all supporting documentation.
'
' U.S. COST PROVIDES THIS PROGRAM "AS-IS" AND WITH ALL FAULTS. U.S. COST, INC.
' DISCLAIMS ANY IMPLIED WARRANTY OF MERCHANTIBILITY OR FITNESS FOR A PARTICULAR USE.
' U.S. COST, INC. DOES NOT WARRANT THAT THE OPERATION OF THE PROGRAM WILL BE
' UNINTERRUPTED OR ERROR FREE.
'
'
On Error GoTo ErrorHandler

Dim objSuccessApp As Object
Dim objDocument As Object
Dim objProject As Object
Dim objTree As Object
Dim lngSelectedTree As Long

    Set objSuccessApp = CreateObject("Success.Application.1")
    
    If objSuccessApp.Documents.Count > 0 Then
    
    	Set objDocument = objSuccessApp.ActiveDocument
    	Set objProject = objDocument.Project

    	If Not objProject.IsTotaled Then
    
       		MsgBox "The active project has not been totaled.",,"Error"
    
       		Set objSuccessApp = Nothing
       		Set objDocument = Nothing
       		Set objProject = Nothing
 
       		Exit Sub

    	End If

        lngSelectedTree = objDocument.SelectedTree
   
        Set objTree = objProject.Trees(lngSelectedTree - 1)

    	RemoveZeroCostAssignments objTree.TreeLevels
    
    	objDocument.Refresh

    	MsgBox "All zero-cost detail item assignments have been removed.",,"Delete Zero Cost Detail Item Assignments"

	Else

       	MsgBox "A project must be opened.",,"Error"	

	End If

    Set objSuccessApp = Nothing
    Set objDocument = Nothing
    Set objProject = Nothing
	Set objTree = Nothing
	
Exit Sub

ErrorHandler:
    
    If Err.Number = 440 Then
        
        MsgBox "An OLE Automation error occurred.",, "Error"
        
    Else
        
        MsgBox Err.Number + 28765 & ": " & Err.Description,,"Error"
        
    End If

    Set objSuccessApp = Nothing
    Set objDocument = Nothing
    Set objProject = Nothing
    Set objTree = Nothing

End Sub

Sub RemoveZeroCostAssignments(objInLevels As Object)
Dim objInLevel As Object
Dim objDetailItemAssignments As Object
Dim objDetailItemAssignment As Object
Dim intDetailCount As Integer
Dim intLevelCount As Integer
Dim intDetail As Integer
Dim intLevel As Integer

    intLevelCount = objInLevels.Count
    
    If intLevelCount > 0 Then
    
        For intLevel = intLevelCount - 1 To 0 Step -1
        
            Set objInLevel = objInLevels(intLevel)
            
            Set objDetailItemAssignments = objInLevel.DetailItemAssignments
                
            intDetailCount = objDetailItemAssignments.Count
                
            If intDetailCount > 0 Then
                    
                For intDetail = intDetailCount - 1 To 0 Step -1
                    
                    Set objDetailItemAssignment = objDetailItemAssignments(intDetail)
                        
                    If objDetailItemAssignment.TotalCost.Total = 0 Then
                        
                       objDetailItemAssignments.Remove objDetailItemAssignment
                       DoEvents
                    
                    End If
                
                Next intDetail
            
            End If
                
            RemoveZeroCostAssignments objInLevel.TreeLevels
            
        Next intLevel
    
    End If
    
    Set objInLevel = Nothing
    Set objDetailItemAssignment = Nothing
    Set objDetailItemAssignments = Nothing

End Sub