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 = "" & bPassung & ""
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 = "" & bToleranz & ""
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 = "" & Passung & ""
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 = "" & MaxWert & "
" & MinWert & ""
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