Dim Language as String
Language="VBScript"


'---------------------------------------------------------------------------
'COPYRIGHT DASSAULT SYSTEMES 2002

' ****************************************************************************
'
' Purpose:       To analyze a subset of dimensions pointed by text leaders
'                in the active drafting document.
'                That macro checks all dimensions pointed by text leader elements.
'                If dimensions have a wrong display (tolerances or wrong frame)
'                text leader object is highlighted.
'
' Assumptions:   A Drafting document should be active
'
' Author: 
' Languages:     VBScript
' Version:       V5R10
' Locales:       English 
' CATIA Level: V5R10 
'
' ****************************************************************************

'---------------------------------------------------------------------------

Sub CATMain()

    ' Set the CATIA popup file alerts to False
    ' It prevents to stop the macro at each alert during its execution
    CATIA.DisplayFileAlerts = False

    ' Optional: allows to find the sample wherever it's installed
    dim sDocPath As String 
    sDocPath=CATIA.SystemService.Environ("CATDocView")
    If (Not CATIA.FileSystem.FolderExists(sDocPath)) Then
      Err.Raise 9999,,"No Doc Path Defined"
    End If

'---------------------------------------------------------------------------
'1/ Read active CATDrawing Document
'---------------------------------------------------------------------------
Dim DrwDoc As DrawingDocument
Set DrwDoc = CATIA.ActiveDocument

' Get Selection Object and clear it
Dim DrwSelect As Selection
Set DrwSelect = DrwDoc.Selection

' Variables declaration
Dim ElemDispatch As CATBaseDispatch
Dim NomObj As String
Dim numsheet As Long
Dim numview As Long
Dim numtxt As Long
Dim numleader As Long

'---------------------------------------------------------------------------
'2/ Scan all the sheet of the current drawing (Included detail sheet)
'---------------------------------------------------------------------------
Dim DrwSheets As DrawingSheets
Set DrwSheets = DrwDoc.Sheets
Dim CurrentSheet As DrawingSheet

'Read the current sheet to restore it at the end of the macro
Dim SheetToRestore As DrawingSheet
Set SheetToRestore = DrwSheets.ActiveSheet

For numsheet = 1 To DrwSheets.Count

   Set CurrentSheet = DrwSheets.Item(numsheet)
   
   ' Active Currentsheet
   CurrentSheet.Activate
   
   ' Clear the selection
   DrwSelect.Clear
   
   Dim DrwViews As DrawingViews
   Set DrwViews = CurrentSheet.Views
   
   'Read the current view to restore it at the end of the macro
   Dim ViewToRestore As DrawingView
   Set ViewToRestore = DrwViews.ActiveView

'---------------------------------------------------------------------------
'3/ Scan all the view of the current sheet
'---------------------------------------------------------------------------
   Dim CurrentView As DrawingView
   
   For numview = 1 To DrwViews.Count
   
      Set CurrentView = DrwViews.Item(numview)
      
      'Active the current view
      CurrentView.Activate

'---------------------------------------------------------------------------
'4/ Scan all the texts of the current view
'---------------------------------------------------------------------------

      Dim Texts As DrawingTexts
      Set Texts = CurrentView.Texts
         
      For numtxt = 1 To Texts.Count
         
         Dim CurrentText As DrawingText
         Set CurrentText = Texts.Item(numtxt)
            
'---------------------------------------------------------------------------
'5/ Scan all the leaders of the current text
'---------------------------------------------------------------------------
               
         Dim Leaders As DrawingLeaders
         Set Leaders = CurrentText.Leaders
 
         For numleader = 1 To Leaders.Count
            Dim CurrentLeader As DrawingLeader
            Set CurrentLeader = Leaders.Item(numleader)
                    
            ' Manage error on HeadTarget method when
            ' no element is pointed by the text leader.
            On Error Resume Next
            ' Get object pointed on the leader
            Set ElemDispatch = Nothing
            Set ElemDispatch = CurrentLeader.HeadTarget
            NomObj = TypeName(ElemDispatch)
                       
'------------------------------------------------------------------------------
'6/ Check tolerances and the frame type of the dimension pointed by text leader
'------------------------------------------------------------------------------

            ' A dimension is pointed by text leader
            If NomObj = "DrawingDimension" Then
                            
               ' Get the dimension object
               Dim PointedDim As DrawingDimension
               Set PointedDim = ElemDispatch
                   
               ' Read dimension tolerances
               Dim oTolType As Long
               Dim oDisplayMode As Long
               Dim oTolName As String
               Dim oUpTolS As String
               Dim oLowTolS As String
               Dim oUpTolD As Double
               Dim oLowTolD As Double
               PointedDim.GetTolerances oTolType, oTolName, oUpTolS, oLowTolS, oUpTolD, oLowTolD, oDisplayMode
    
               ' Read dimension frame type
               Dim TypeFrame As CatDimFrame
               TypeFrame = PointedDim.ValueFrame
               
'---------------------------------------------------------------------------
'7/ Change the visualization of the text leader linked to that dimension
'---------------------------------------------------------------------------
            
               ' If dimension does not respect the criteria text leader object is highlighted
               If oTolType <> 0 Or TypeFrame <> catFraRectangle Then
                  DrwSelect.Add CurrentText
                  DrwSelect.VisProperties.SetRealColor 255, 0, 0, 0
                  DrwSelect.VisProperties.SetRealWidth 6, 1
               End If
             
            End If
         Next

      Next

    'Restore the view
    ViewToRestore.Activate

   Next

 Next 

'Restore the Drawing Document sheet
SheetToRestore.Activate
   
End Sub