Dim PassungsTabelle As String
Dim Passungen(406) As ePassung
Dim InklGrenzwerte As Boolean

Type ePassung
    Norm As String
    Über(82) As Single
    Bis(82) As Single
    Max(82) As Double
    Min(82) As Double
End Type

Type MaxMin
    MaxWert As String
    MinWert As String
End Type

Dim GefundenePassungen(100) As tPassungen
Type tPassungen
    Vorzeichen As String
    Zahlenwert As Double
    Passung As String
End Type

Public Sub PassungsTabelle_erstellen()
Dim ZellenBreite As Double, ZellenHöhe As Double, BeschriftungsTextHöhe As Double, HaupttextTextHöhe As Double, TolleranzTextHöhe As Double
Dim oApp As Inventor.Application: Set oApp = ThisApplication

PassungsTabelle = ThisApplication.InstallPath & "Passungen_ISO268.txt"


ZellenBreite = 2
ZellenHöhe = "0,55"
HaupttextTextHöhe = "0,25"
BeschriftungsTextHöhe = "0,25"
TolleranzTextHöhe = "0,15"

'Eingefügt EIBe 3D 2021-05-06
oApp.ScreenUpdating = False

Dim oTrans As Inventor.Transaction
Set oTrans = ThisApplication.TransactionManager.StartTransaction(oApp.ActiveDocument, "Passungstabelle erstellen")
'***

Call modPassungstabelle.ErstellePassungsliste("Passung", "Toleranz", ZellenBreite, ZellenHöhe, HaupttextTextHöhe, BeschriftungsTextHöhe, TolleranzTextHöhe)

'Eingefügt EIBe 3D 2021-05-06
oTrans.End

oApp.ScreenUpdating = True
oApp.ActiveView.Update
'***
End Sub

Private Sub ErstellePassungsliste(bPassung As String, bToleranz As String, ZellenBreite As Double, ZellenHöhe As Double, BeschriftungsTextHöhe As Double, HaupttextTextHöhe As Double, TolleranzTextHöhe As Double)
Erase Passungen: Erase GefundenePassungen
PassungenAuslesen
Call getPassungen
    On Error Resume Next
    Dim oDoc As DrawingDocument:     Set oDoc = ThisApplication.ActiveDocument
    Dim oSheet As Sheet:             Set oSheet = oDoc.ActiveSheet
    Dim oTG As TransientGeometry:    Set oTG = ThisApplication.TransientGeometry
    Dim oSketch As DrawingSketch, iX As Single
    Dim ZellenStartPunktX As Double, ZellenStartPunktY As Double
    
    'If oSheet.Width > 21 Then
    '    ZellenStartPunktX = oSheet.Width - 22 - ZellenBreite
    '    ZellenStartPunktY = 1
    ''Else
    '    ZellenStartPunktX = 1.5
    '    ZellenStartPunktY = 6.04
    'End If
    
    ZellenStartPunktX = 2.5 'Position X
    ZellenStartPunktY = 2 'Position Y

'Eingefügt EIBe 3D 2021-05-06
    Dim VersatzTextboxX As Double
    VersatzTextboxX = ZellenBreite / 2
'    VersatzTextboxX = 0
'***
    
    For i = 1 To oSheet.Sketches.Count
        If oSheet.Sketches.Item(i).name = "Passungstabelle" Then oSheet.Sketches.Item(i).Delete   'wenn Passungstabelle existiert bereits => löschen
    Next i
    
    Set oSketch = oSheet.Sketches.Add
    oSheet.Sketches.Item(oSheet.Sketches.Count).name = "Passungstabelle"
    
    Dim oTextbox As Inventor.TextBox
    Call oSketch.Edit
    
  'Beschriftung erstellen
    Call oSketch.SketchLines.AddAsTwoPointRectangle(oTG.CreatePoint2d(ZellenStartPunktX, ZellenStartPunktY), oTG.CreatePoint2d(ZellenStartPunktX + ZellenBreite, ZellenStartPunktY + ZellenHöhe))
    Call oSketch.SketchLines.AddAsTwoPointRectangle(oTG.CreatePoint2d(ZellenStartPunktX + ZellenBreite * 2, ZellenStartPunktY), oTG.CreatePoint2d(ZellenStartPunktX + ZellenBreite, ZellenStartPunktY + ZellenHöhe))
    
    Set oTextbox = oSketch.TextBoxes.AddFitted(oTG.CreatePoint2d(ZellenStartPunktX + VersatzTextboxX, ZellenStartPunktY + ZellenHöhe), bPassung): 'Geändert + VersatzTextboxX EIBe 3D 2021-05-06
        oTextbox.FormattedText = "<StyleOverride FontSize='" & BeschriftungsTextHöhe & "' Bold='True'>" & bPassung & "</StyleOverride>"
        oTextbox.Width = ZellenBreite: oTextbox.Height = ZellenHöhe
        oTextbox.HorizontalJustification = kAlignTextCenter: oTextbox.VerticalJustification = kAlignTextMiddle
        oTextbox.SingleLineText = True
    
    Set oTextbox = oSketch.TextBoxes.AddFitted(oTG.CreatePoint2d(ZellenStartPunktX + VersatzTextboxX + ZellenBreite, ZellenStartPunktY + ZellenHöhe), bToleranz): 'Geändert + VersatzTextboxX EIBe 3D 2021-05-06
        oTextbox.FormattedText = "<StyleOverride FontSize='" & HaupttextTextHöhe & "' Bold='True'>" & bToleranz & "</StyleOverride>"
        oTextbox.Width = ZellenBreite: oTextbox.Height = ZellenHöhe
        oTextbox.HorizontalJustification = kAlignTextCenter: oTextbox.VerticalJustification = kAlignTextMiddle
        oTextbox.SingleLineText = True
  'Beschriftung erstellen ENDE
    
    For iX = 1 To UBound(GefundenePassungen)
    If GefundenePassungen(iX).Zahlenwert = 0 Then Exit For
    
    'Passung (Zahl & Passung) eintragen
    Passung = GefundenePassungen(iX).Vorzeichen & GefundenePassungen(iX).Zahlenwert & " " & GefundenePassungen(iX).Passung
    Set oTextbox = oSketch.TextBoxes.AddFitted(oTG.CreatePoint2d(ZellenStartPunktX + VersatzTextboxX, ZellenStartPunktY + ZellenHöhe + ZellenHöhe * iX), Passung): 'Geändert + VersatzTextboxX EIBe 3D 2021-05-06
        oTextbox.FormattedText = "<StyleOverride FontSize='" & HaupttextTextHöhe & "' Bold='False'>" & Passung & "</StyleOverride>"
        oTextbox.Width = ZellenBreite: oTextbox.Height = ZellenHöhe
        oTextbox.HorizontalJustification = kAlignTextCenter: oTextbox.VerticalJustification = kAlignTextMiddle
        oTextbox.SingleLineText = True
        
    Call oSketch.SketchLines.AddAsTwoPointRectangle(oTG.CreatePoint2d(ZellenStartPunktX, ZellenStartPunktY + ZellenHöhe * iX), oTG.CreatePoint2d(ZellenStartPunktX + ZellenBreite, ZellenStartPunktY + ZellenHöhe + ZellenHöhe * iX))
    
    'Toleranz eintragen
    MaxWert = GrenzwertAbfrage(GefundenePassungen(iX).Zahlenwert, GefundenePassungen(iX).Passung).MaxWert
    If MaxWert > 0 And MaxWert <> "---" Then MaxWert = "+" & MaxWert
    MinWert = GrenzwertAbfrage(GefundenePassungen(iX).Zahlenwert, GefundenePassungen(iX).Passung).MinWert
    If MinWert > 0 And MinWert <> "---" Then MinWert = "+" & MinWert
    Dim sText As String: sText = MaxWert & vbNewLine & MinWert
    
    Set oTextbox = oSketch.TextBoxes.AddFitted(oTG.CreatePoint2d(ZellenStartPunktX + VersatzTextboxX + ZellenBreite, ZellenStartPunktY + ZellenHöhe + ZellenHöhe * iX), sText) 'Geändert + VersatzTextboxX EIBe 3D 2021-05-06
        oTextbox.FormattedText = "<StyleOverride FontSize='" & TolleranzTextHöhe & "' Bold='False'>" & MaxWert & "</StyleOverride><Br/><StyleOverride FontSize='" & TolleranzTextHöhe & "' Bold='False'>" & MinWert & "</StyleOverride>"
        oTextbox.Width = ZellenBreite: oTextbox.Height = ZellenHöhe
        oTextbox.HorizontalJustification = kAlignTextCenter: oTextbox.VerticalJustification = kAlignTextMiddle
        oTextbox.SingleLineText = False
    Call oSketch.SketchLines.AddAsTwoPointRectangle(oTG.CreatePoint2d(ZellenStartPunktX + ZellenBreite, ZellenStartPunktY + ZellenHöhe * iX), oTG.CreatePoint2d(ZellenStartPunktX + ZellenBreite * 2, ZellenStartPunktY + ZellenHöhe + ZellenHöhe * iX))
    
    'Grenzwerte eintragen
    If InklGrenzwerte = True Then
        Dim MaßMax As Double, MaßMin As Double
        MaßMax = GefundenePassungen(iX).Zahlenwert + MaxWert
        MaßMin = GefundenePassungen(iX).Zahlenwert + MinWert
    End If
    
    Next iX

    oSketch.ExitEdit
End Sub

Private Function GrenzwertAbfrage(Maß As Double, Passung As String) As MaxMin
If InStr(Passung, "/") <> 0 Then GrenzwertAbfrage.MaxWert = "---": GrenzwertAbfrage.MinWert = "---" 'bei Mehrfacheintragungen -> nichts ausgeben
Dim iNorm As Double, iWerte As Double
For iNorm = 1 To 406
    If Passung = Passungen(iNorm).Norm Then
        For iWerte = 1 To 82
            Select Case Maß
                Case Passungen(iNorm).Über(iWerte) To Passungen(iNorm).Bis(iWerte)
                GrenzwertAbfrage.MaxWert = Passungen(iNorm).Max(iWerte) / 1000
                GrenzwertAbfrage.MinWert = Passungen(iNorm).Min(iWerte) / 1000
                Exit Function
            End Select
        Next iWerte
    End If
Next iNorm
End Function

Private Sub PassungenAuslesen()
Dim DateiInhalt As String, tmpZeile As Variant, tmpReihe As Variant, iNorm As Single, tmpNorm As Variant, iÜberBis As Single, tmpPos As Single, iMaxMin As Single
Dim xFileName As String
Dim tmpZeilenInhalt As Variant
Dim tmpÜber As Variant
Dim tmpBis As Variant

'Datei einlesen
Dim fNum As Integer:  fNum = FreeFile
Open PassungsTabelle For Input As fNum
     DateiInhalt = Input$(LOF(fNum), #fNum)
Close fNum
'Einlesen ende

On Error Resume Next
tmpZeile = Split(DateiInhalt, vbNewLine)
tmpÜber = Split(tmpZeile(0), vbTab):    tmpBis = Split(tmpZeile(1), vbTab)

For iNorm = 1 To 406
    tmpNorm = Split(tmpZeile(iNorm + 2), vbTab)
    Passungen(iNorm).Norm = tmpNorm(0)
    
    tmpPos = 1
    For iÜberBis = 1 To 82 Step 2
        Passungen(iNorm).Über(tmpPos) = tmpÜber(iÜberBis)
        Passungen(iNorm).Bis(tmpPos) = tmpBis(iÜberBis)
        tmpPos = tmpPos + 1
    Next iÜberBis
    
    tmpPos = 1
    For iMaxMin = 1 To 82 Step 2
        Passungen(iNorm).Max(tmpPos) = tmpNorm(iMaxMin)
        Passungen(iNorm).Min(tmpPos) = tmpNorm(iMaxMin + 1)
        tmpPos = tmpPos + 1
    Next iMaxMin
Next iNorm
End Sub

Private Function getPassungen(Optional AutoNummerierung As Boolean, Optional MsgBoxAusgabe As Boolean) 'alle Prüfmaße ermitteln 18.09.2017
  Dim oDrawDoc As DrawingDocument, dimText As String
  Dim Shape As InspectionDimensionShapeEnum, PrüfBezeichnung As String, PrüfRate As String
  Dim tmpText As String, tmpIndex As Single: tmpIndex = 1
  Dim Pos As String, Vorsatz As String, Art As String, Wert As String, Passung As String, ObTol As String, UntTol As String
  If ThisApplication.ActiveDocumentType <> kDrawingDocumentObject Then MsgBox "aktuelles Dokument = keine Zeichnung": Exit Function
  Set oDrawDoc = ThisApplication.ActiveDocument
  oDrawDoc.Update
  Dim gPassungen As Double: gPassungen = 1
  Passung = ""
  For i = 1 To oDrawDoc.ActiveSheet.DrawingDimensions.Count 'alle Bemaßungen durchlaufen und nur "Tolleranzmaße" erfassen
     If oDrawDoc.ActiveSheet.DrawingDimensions(i).Tolerance.ToleranceType >= 31241 And oDrawDoc.ActiveSheet.DrawingDimensions(i).Tolerance.ToleranceType <= 31244 Then
        Pos = "": Vorsatz = "": Art = "": Wert = "": Passung = "": ObTol = "": UntTol = "" 'Variablen leeren
        
      '### wennn Autonummerierung erwünscht, dann Wert für Prüfbezeichnung setzen
        If AutoNummerierung = True Then Call oDrawDoc.ActiveSheet.DrawingDimensions(i).SetInspectionDimensionData(kRoundedEndsInspectionBorder, tmpIndex): tmpIndex = tmpIndex + 1

      '### wenn "Form" <> "rund" dann auf "rund" setzen
        'If Shape <> kRoundedEndsInspectionBorder Then Call oDrawDoc.ActiveSheet.DrawingDimensions(i).SetInspectionDimensionData(kRoundedEndsInspectionBorder, "", "")
        
      '### angezeigten Text temporär merken
        tmpText = oDrawDoc.ActiveSheet.DrawingDimensions(i).Text.Text
        
      '### Text vor dem Bemaßungswert
        Vorsatz = Left(oDrawDoc.ActiveSheet.DrawingDimensions(i).Text.FormattedText, InStr(1, oDrawDoc.ActiveSheet.DrawingDimensions(i).Text.FormattedText, "<") - 1)
        
      '### Bemaßungswert
        Wert = FormatNumber(oDrawDoc.ActiveSheet.DrawingDimensions(i).ModelValue * 10, oDrawDoc.ActiveSheet.DrawingDimensions(i).Precision): _
               If Right(Wert, 2) = ",0" Then Wert = Left(Wert, Len(Wert) - 2)
        
      '### Durchmesser
        If InStr(1, tmpText, "n" & Wert) <> 0 And Art = "" Then Art = "Ø"
        
      '### Radius
        If InStr(1, tmpText, "R" & Wert) <> 0 And Art = "" Then Art = "R"
        
      '### Winkelbemaßung
        If oDrawDoc.ActiveSheet.DrawingDimensions(i).Type = kAngularGeneralDimensionObject Then _
            Art = "W": Wert = FormatNumber(oDrawDoc.ActiveSheet.DrawingDimensions(i).ModelValue * 57.2957795130824, oDrawDoc.ActiveSheet.DrawingDimensions(i).Precision): _
               If Right(Wert, 2) = ",0" Then Wert = Left(Wert, Len(Wert) - 2)
      
      '### Passungen auslesen
        If oDrawDoc.ActiveSheet.DrawingDimensions(i).Tolerance.HoleTolerance <> "" Then Passung = oDrawDoc.ActiveSheet.DrawingDimensions(i).Tolerance.HoleTolerance
        If oDrawDoc.ActiveSheet.DrawingDimensions(i).Tolerance.ShaftTolerance <> "" Then Passung = oDrawDoc.ActiveSheet.DrawingDimensions(i).Tolerance.ShaftTolerance
        If oDrawDoc.ActiveSheet.DrawingDimensions(i).Tolerance.ShaftTolerance <> "" And oDrawDoc.ActiveSheet.DrawingDimensions(i).Tolerance.HoleTolerance <> "" Then _
            Passung = oDrawDoc.ActiveSheet.DrawingDimensions(i).Tolerance.HoleTolerance & "/" & oDrawDoc.ActiveSheet.DrawingDimensions(i).Tolerance.ShaftTolerance
      
      '### Tolleranzen auslesen
        If oDrawDoc.ActiveSheet.DrawingDimensions(i).Tolerance.Upper <> 0 Then ObTol = FormatNumber(oDrawDoc.ActiveSheet.DrawingDimensions(i).Tolerance.Upper * 10, oDrawDoc.ActiveSheet.DrawingDimensions(i).TolerancePrecision)
        If oDrawDoc.ActiveSheet.DrawingDimensions(i).Tolerance.Lower <> 0 Then UntTol = FormatNumber(oDrawDoc.ActiveSheet.DrawingDimensions(i).Tolerance.Lower * 10, oDrawDoc.ActiveSheet.DrawingDimensions(i).TolerancePrecision)
        If oDrawDoc.ActiveSheet.DrawingDimensions(i).Tolerance.ToleranceType = kSymmetricTolerance Then UntTol = ObTol * -1
        
      '### neue Werte merken
        dimText = dimText & Pos & vbTab & Vorsatz & vbTab & Art & vbTab & Wert & vbTab & Passung & vbTab & ObTol & vbTab & UntTol & vbNewLine
        'dimText = dimText & Pos & vbTab & Vorsatz & vbTab & Art & vbTab & Wert & vbTab & Passung & vbTab & oDrawDoc.ActiveSheet.DrawingDimensions(i).Tolerance.ToleranceType & vbNewLine
        
        GefundenePassungen(gPassungen).Vorzeichen = Art
        GefundenePassungen(gPassungen).Zahlenwert = Wert
        GefundenePassungen(gPassungen).Passung = Passung
        gPassungen = gPassungen + 1
    End If
  Next i
 '### Rückgabewert
  getPassungen = dimText
  
 '### wenn MsgBoxAusgabe erwünscht dann
 If MsgBoxAusgabe = True Then MsgBox "Pos." & vbTab & "Vorsatz" & vbTab & "Art" & vbTab & "Wert" & vbTab & "Passung" & vbTab & "Ob.Tol" & vbTab & "Unt.Tol" & vbNewLine & dimText
End Function