Attribute VB_Name = "modTolAndPassTab"
Sub TolAndPassTab()
Dim oApplication As Inventor.Application
Set oApplication = GetObject(, "Inventor.Application")

Dim oDoc As Document
Set oDoc = oApplication.ActiveDocument

'sprawdz czy otwarty dokument jest rysunkuem
If Not oDoc.DocumentType = kDrawingDocumentObject Then Exit Sub

Dim CollPasDim As Collection
Set CollPasDim = New Collection

For Each el In oDoc.ActiveSheet.DrawingDimensions
    If el.Tolerance.ToleranceType <> kDefaultTolerance Then
        CollPasDim.Add el
    End If
Next el

If CollPasDim.Count = 0 Then Exit Sub

' Set a reference to the drawing document.
' This assumes a drawing document is active.
Dim oDrawDoc As DrawingDocument
Set oDrawDoc = ThisApplication.ActiveDocument

' Set a reference to the active sheet.
Dim oSheet As Sheet
Set oSheet = oDrawDoc.ActiveSheet

'ilosc kolumn
k = 4

' Set the column titles
Dim oTitles() As String
ReDim Preserve oTitles(1 To k) As String
oTitles(1) = "Wymiar"
oTitles(2) = "Pasowanie"
oTitles(3) = "Odchyłki"
oTitles(4) = "Tolerancja"

' Set the contents of the custom table (contents are set row-wise)
Dim oContents() As String

i = 1
For Each el In CollPasDim

    ReDim Preserve oContents(1 To i + k - 1)
    oContents(i) = Round(el.ModelValue * 10, el.Precision)
    
    If el.Tolerance.HoleTolerance <> "" And el.Tolerance.ShaftTolerance <> "" Then
        oContents(i + 1) = el.Tolerance.HoleTolerance & "/" & el.Tolerance.ShaftTolerance
    Else
        oContents(i + 1) = el.Tolerance.HoleTolerance & el.Tolerance.ShaftTolerance
    End If
     
    If el.Tolerance.Upper = 0 And el.Tolerance.Lower = 0 Then
        oContents(i + 3) = ""
        oContents(i + 2) = ""
    Else
        oContents(i + 3) = Round((el.ModelValue + el.Tolerance.Upper) * 10, el.TolerancePrecision) & vbCrLf & Round((el.ModelValue + el.Tolerance.Lower) * 10, el.TolerancePrecision) 'el.TolerancePrecision
        oContents(i + 2) = Round(el.Tolerance.Upper * 10, el.TolerancePrecision) & vbCrLf & Round(el.Tolerance.Lower * 10, el.TolerancePrecision) ' Format(el.Tolerance.Lower * 10, "0.000")
    End If
    i = i + k

Next el

' szerokosc kolumn
Dim oColumnWidths() As Double
ReDim Preserve oColumnWidths(1 To k) As Double
oColumnWidths(1) = 1.8
oColumnWidths(2) = 2
oColumnWidths(3) = 2
oColumnWidths(4) = 2.5

' punkt wstawienia
Dim oBorder As Border
Set oBorder = oSheet.Border

Dim oPlacementPoint As Point2d

If Not oBorder Is Nothing Then
    Set oPlacementPoint = oBorder.RangeBox.MaxPoint
Else
    Set oPlacementPoint = ThisApplication.TransientGeometry.CreatePoint2d(oSheet.Width, oSheet.Height)
End If

' Create the custom table
Dim oCustomTable As CustomTable
Set oCustomTable = oSheet.CustomTables.Add("Tabela pasowań", ThisApplication.TransientGeometry.CreatePoint2d(oSheet.Width - oPlacementPoint.x, oPlacementPoint.Y), _
                                    k, UBound(oContents) / k, oTitles, oContents, oColumnWidths)
                                    
' wyrównanie kolumn
oCustomTable.Columns.Item(1).ValueHorizontalJustification = kAlignTextLeft
oCustomTable.Columns.Item(2).ValueHorizontalJustification = kAlignTextCenter
oCustomTable.Columns.Item(3).ValueHorizontalJustification = kAlignTextRight
oCustomTable.Columns.Item(4).ValueHorizontalJustification = kAlignTextRight
oCustomTable.ShowTitle = False

' Create a table format object
Dim oFormat As TableFormat
Set oFormat = oSheet.CustomTables.CreateTableFormat

' ustawienie grubosci lini
oFormat.OutsideLineWeight = 0.05
oFormat.InsideLineWeight = 0.01

' formatowanie
oCustomTable.OverrideFormat = oFormat

'zwolnienie pamieci
Set CollTolDim = Nothing
Set oDoc = Nothing
Set oDrawDoc = Nothing
Set oSheet = Nothing
Set oCustomTable = Nothing
Set oFormat = Nothing
Set oApplication = Nothing
End Sub