Extracting Both Notes and Dimensions with Tolerance linked with Position Text

[Balaji2021]

Hi

I Have a requirement for extracting Dimension with Tolerance values along with the Text linked with the Dimension

I used below code, to extract the dimension Values but i would like to have one more Column (F) to capture the Text linked with the Dimension.



Sub CATMain()

Dim myDrawing As DrawingDocument

Dim oTolType As Long
Dim oTolName As String
Dim oUpTol As String
Dim oLowTol As String
Dim odUpTol As Double
Dim odLowTol As Double
Dim oDisplayMode As Long
Dim MyFormatPrecision ' As Double
' ------------------------------------------------------
' *** Vérifie si le document actif est un CATDrawing ***
' ------------------------------------------------------

On Error Resume Next
Set myDrawing = CATIA.ActiveDocument
If (Err.Number <> 0) Then
MsgBox ("Un CATDrawing doit être actif")

Exit Sub
End If
If (InStr(myDrawing.Name, ".CATDrawing")) = 0 Then
MsgBox ("La fenêtre active doit être un CATDrawing")
Exit Sub
End If
Err.Clear
On Error GoTo 0

' *** Sélectionne toutes les cotes ***

Dim selection1 As Selection
Set selection1 = myDrawing.Selection
selection1.Clear
selection1.Search "CATDrwSearch.DrwDimension,all"

' *** Lance Excel ***

Dim xl As Object 'Excel.Application
On Error Resume Next
Set xl = GetObject(, "Excel.Application")
If Err <> o Then
Set xl = CreateObject("Excel.Application")
xl.Visible = True
End If

Set Workbooks = xl.Application.Workbooks
Set myworkbook = xl.Workbooks.Add
Set myworksheet = xl.ActiveWorkbook.Add
Set myworksheet = xl.Sheets.Add

' *** titre des colonnes d'Excel ***

myworksheet.Range("A1").Value = "Type"
myworksheet.Range("B1").Value = "Dimension"
myworksheet.Range("C1").Value = "Tol. min"
myworksheet.Range("D1").Value = "Tol. max"
myworksheet.Range("E1").Value = "View name"

' *** traitement des cotations ***

For i = 1 To selection1.Count
Set MyDimension = selection1.Item(i).Value
MyDimensionValue = MyDimension.GetValue.Value
'Get the number of decimals
MyFormatPrecision = Len(Str(MyDimension.GetValue.GetFormatPrecision(1))) - 2 ' (1: main value; 2: dual value )
' Get the dimension unit : =0 if mm / =1 if inch
MyDimensionUnit = MyDimension.GetValue.GetDisplayUnit(1) ' (1: main value; 2: dual value )
'Convert the dimension if inch
If MyDimensionUnit = 1 Then
myworksheet.Cells(i + 1, 2).Value = Round(MyDimensionValue / 25.4, MyFormatPrecision)
Else
myworksheet.Cells(i + 1, 2).Value = Round(MyDimensionValue, MyFormatPrecision)
End If
' traitement des tolérances
MyDimension.GetTolerances oTolType, oTolName, oUpTol, oLowTol, odUpTol, odLowTol, oDisplayMode

If oTolType = 1 Then 'tolérance numérique
'Convert the tolerance if inche
If MyDimensionUnit = 1 Then
myworksheet.Cells(i + 1, 3).Value = Round(odLowTol / 25.4, MyFormatPrecision)
myworksheet.Cells(i + 1, 4).Value = Round(odUpTol / 25.4, MyFormatPrecision)
Else
myworksheet.Cells(i + 1, 3).Value = odLowTol
myworksheet.Cells(i + 1, 4).Value = odUpTol
End If
End If
If oTolType = 2 Then 'tolérance alphanumérique
myworksheet.Cells(i + 1, 3).Value = oLowTol
myworksheet.Cells(i + 1, 4).Value = oUpTol
End If
' traitement des types de cotations
MyDimType = MyDimension.DimType
Select Case MyDimType
Case 5, 6, 7, 8, 17, 19 'cote type rayon
MyDimTypeTexte = "R"
Case 9, 10, 11, 12, 13, 18
MyDimTypeTexte = "&Oslash;" 'cote type diamètre
Case 14
MyDimTypeTexte = "Ch" 'cote type chanfrein
Case 4
MyDimTypeTexte = "Angle" 'cote d'angle
Case Else
MyDimTypeTexte = "" 'cote type longueur-distance
End Select



myworksheet.Cells(i + 1, 1).Value = MyDimTypeTexte

' to get view name added juin 2018
myworksheet.Cells(i + 1, 5).Value = MyDimension.Parent.Parent.Name
odLowTol = 0
odUpTol = 0
oUpTol = ""
oLowTol = ""

Next

End Sub


Thanks
Balaji

 

[Balaji2021]

Requesting Support to extract Text linked with Dimensions, as i posted in the previous Thread.