Sub CATMain()

'unten links platzieren
Dim x, y
x = 8
y = 8

Dim CATIA As Object
Set CATIA = GetObject(, "CATIA.application")

Dim MyDrwDoc As DrawingDocument
Dim MySheets As DrawingSheets
Dim MySheet As DrawingSheets
Dim MyViews As DrawingViews
Dim MyView As DrawingView
Dim MyDimensions  As DrawingDimensions
Dim MyDimension As DrawingDimension
Dim oName
Dim ViewCount As Integer
Dim MyFileName As String
Dim fso
Dim sDatei
Dim MyValue
Dim MyPrec
Dim sZeile As String
Dim MyTempArray
Dim Array1(100) As Double
Dim Array2(100, 3) As String


Dim i As Integer
Dim j As Integer



Set MyDrwDoc = CATIA.ActiveDocument
Set MySheets = MyDrwDoc.Sheets
Set MyViews = MySheets.ActiveSheet.Views

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 oDispl As Long


'Alte Tabelle löschen
Set Selection = MyDrwDoc.Selection
Selection.Search "(Name:*ABMASSTABELLE* );Alle"
If Selection.Count > 0 Then
    Selection.Delete
    Selection.Clear
End If

'*** Hintergrundansicht aktivieren ********

MyViews.Item("View.2").Activate

'***********************

    'beginn Tabelle**************
    Set DrwView = MySheets.ActiveSheet.Views.ActiveView
    Dim MyTable As Variant 'DrawingTable
    Set MyTable = DrwView.Tables.Add(x, y, 1, 3, 6, 27)
    MyTable.Name = "ABMASSTABELLE"
    MyTable.SetCellString 1, 1, "Passmaß"
    MyTable.SetCellAlignment 1, 1, CatTableMiddleCenter
    Set oName = MyTable.GetCellObject(1, 1)
    oName.SetFontSize 0, 0, 2.5
    oName.SetFontName 0, 0, "ISOCPEUR (TrueType)"
    MyTable.SetCellString 1, 2, "Mindestmaß"
    MyTable.SetCellAlignment 1, 2, CatTableMiddleCenter
    Set oName = MyTable.GetCellObject(1, 2)
    oName.SetFontSize 0, 0, 2.5
    oName.SetFontName 0, 0, "ISOCPEUR (TrueType)"
    MyTable.SetCellString 1, 3, "Höchstmaß"
    MyTable.SetCellAlignment 1, 3, CatTableMiddleCenter
    Set oName = MyTable.GetCellObject(1, 3)
    oName.SetFontSize 0, 0, 2.5
    oName.SetFontName 0, 0, "ISOCPEUR (TrueType)"
    
    MyTable.AnchorPoint = CatTableBottomLeft
    '******************************

'Ansichten durchspielen
'Set MyDimensions = MyViews.ActiveView.Dimensions

ViewCount = 1
i = 0

Do While MyViews.Count > ViewCount - 1

    Set MyDimensions = MyViews.Item(ViewCount).Dimensions
    
Dim Item As Integer
Item = 1

Do While MyDimensions.Count > Item - 1

    '******************************************
    MyFileName = "W:\Catia\Einstellungen\tolerance.kon" 'hier das Verzeichnis der Abmaßtabelle anpassen!!!
    Set fso = CreateObject("Scripting.FileSystemObject")
    If fso.FileExists(MyFileName) Then
    Set sDatei = fso.OpenTextFile(MyFileName)
    End If
    '******************************************
    
    Set MyDimension = MyDimensions.Item(Item)
    MyValue = MyDimension.GetValue.Value
    MyPrec = MyDimension.GetValue.GetFormatPrecision(1)
    
    'hier runden wenn nötig
    MyValue = MyValueRound(MyValue, MyPrec)
         
    oTolType = 0
    oTolName = ""
    oUpTol = ""
    oLowTol = ""
    odUpTol = 0
    odLowTol = 0
    oDispl = 0

    MyDimension.GetTolerances oTolType, oTolName, oUpTol, oLowTol, odUpTol, odLowTol, oDispl
        
    If oTolType = 2 Then
    

        Do While Not (sDatei.AtEndOfStream)
            sZeile = sDatei.ReadLine
            MyTempArray = Split(sZeile, ";")
            
            If oUpTol = MyTempArray(0) Or oLowTol = MyTempArray(0) Then
            
                If CLng(MyValue) > CLng(MyTempArray(1)) And CLng(MyValue) <= CLng(MyTempArray(2)) Then
                    
                    
                    If i > 100 Then
                        MsgBox "Die Anzahl der Passungen übersteigt 100." & vbLf & _
                               "Macro wird abgebrochen"
                        MyViews.Item("View.1").Activate
                        Exit Sub
                    End If
                    
                       Array1(i) = MyValue
                       Array2(i, 0) = MyValue
                       Array2(i, 1) = " " & oUpTol & oLowTol
                       Array2(i, 2) = MyLeerHinzu(MyValue + MyTempArray(3))
                       Array2(i, 3) = MyLeerHinzu(MyValue + MyTempArray(4))
                       i = i + 1
                       
                End If
            End If
        Loop
        
    End If
                  
    Item = Item + 1
            
Loop

ViewCount = ViewCount + 1

Loop

QuickSort Array1

'doppelte erkennen
For i = 0 To 100
 For j = i + 1 To 100
  If Array1(i) = Array1(j) Then
  Array1(i) = 0
  End If
 Next j
Next i
For i = 0 To 100
 For j = i + 1 To 100
  If Array2(i, 0) = Array2(j, 0) And Array2(i, 1) = Array2(j, 1) Then Array2(i, 0) = 0
 Next j
Next i


For i = 0 To 100

 For j = 0 To 99
   
  If Array1(i) = Array2(j, 0) Then
   If Array1(i) = 0 Or Array2(j, 0) = 0 Then GoTo weiter
                    MyTable.AddRow 1
                                                         
                    MyTable.SetCellString 1, 1, Array2(j, 0) & " " & Array2(j, 1)
                    MyTable.SetCellAlignment 1, 1, CatTableMiddleCenter
                    Set oName = MyTable.GetCellObject(1, 1)
                    oName.SetFontSize 0, 0, 2.5
                    MyTable.SetCellString 1, 2, Array2(j, 2)
                    MyTable.SetCellAlignment 1, 2, CatTableMiddleRight
                    Set oName = MyTable.GetCellObject(1, 2)
                    oName.SetFontSize 0, 0, 2.5
                    MyTable.SetCellString 1, 3, Array2(j, 3)
                    MyTable.SetCellAlignment 1, 3, CatTableMiddleRight
                    Set oName = MyTable.GetCellObject(1, 3)
                    oName.SetFontSize 0, 0, 2.5
   End If
weiter:
 Next j
Next i


'Tabelle formatieren
Selection.Search "(Name:*ABMASSTABELLE* );Alle"
Selection.VisProperties.SetRealColor 0, 0, 0, 1
Selection.VisProperties.SetRealWidth 2, 0
Selection.Clear

'Arbeitsansicht aktivieren

MyViews.Item("View.1").Activate

End Sub
Public Static Function Round1( _
    ByVal Value As Variant, _
    Optional ByVal Digits As Integer = 0 _
  ) As Variant
  Dim i As Long
  Dim Pot10(-28 To 28) As Variant

  If i = 0 Then
    For i = LBound(Pot10) To UBound(Pot10)
      Pot10(i) = CDec(10 ^ i)
    Next i
  End If
  
On Error Resume Next
    If Value > 0 Then
    Round1 = Int(Value * Pot10(Digits) + 0.5) * Pot10(-Digits)
    Else
    Round1 = -Int(-Value * Pot10(Digits) + 0.5) * Pot10(-Digits)
    End If
    If Err.Number Then Round1 = Value
On Error GoTo 0
  
End Function
Function MyValueRound(MyValue, MyPrec) As Double
Dim MyTemp
Dim MyLength

On Error Resume Next
MyTemp = Split(MyPrec, ",")
MyLength = Len(MyTemp(1))
MyValueRound = Round(MyValue, MyLength)
End Function
Function MyLeerHinzu(MyValue) As String
Dim MyTempArray

On Error GoTo weiter
    MyTempArray = Split(MyValue, ",")
    Do While Len(MyTempArray(1)) < 3
        MyTempArray(1) = MyTempArray(1) & 0
    Loop
    MyValue = MyTempArray(0) & "," & MyTempArray(1)
    MyLeerHinzu = MyValue & " "
    Exit Function

weiter:
MyLeerHinzu = MyValue & ",000 "
End Function

' QuickSort-Algorithmus
'
' vSort() : zu sortierendes Array
' lngStart, lngEnd: zu sortierender Bereich
' ==========================================
Public Sub QuickSort(vSort As Variant, _
  Optional ByVal lngStart As Variant, _
  Optional ByVal lngEnd As Variant)

  ' Wird die Bereichsgrenze nicht angegeben,
  ' so wird das gesamte Array sortiert
  
  If IsMissing(lngStart) Then lngStart = LBound(vSort)
  If IsMissing(lngEnd) Then lngEnd = UBound(vSort)
  
  Dim i As Long
  Dim j As Long
  Dim h As Variant
  Dim x As Variant
  
  i = lngStart: j = lngEnd
  x = vSort((lngStart + lngEnd) / 2)
  
  ' Array aufteilen
  Do
  
    While (vSort(i) < x): i = i + 1: Wend
    While (vSort(j) > x): j = j - 1: Wend
        
    If (i <= j) Then
      ' Wertepaare miteinander tauschen
      h = vSort(i)
      vSort(i) = vSort(j)
      vSort(j) = h
      i = i + 1: j = j - 1
    End If
  Loop Until (i > j)
  
  ' Rekursion (Funktion ruft sich selbst auf)
  If (lngStart < j) Then QuickSort vSort, lngStart, j
  If (i < lngEnd) Then QuickSort vSort, i, lngEnd
End Sub