---

Prufmase_ACAD.png

Hallo Leute,
ich versuche momentan in AutoCAD und Inventor eine Prüfmaßeexportfunktion zu erstellen.
In AutoCAD läuft es schon sehr gut. Das Makro durchläuft alle Maße und wenn es ein Prüfmaß ist, wird daraus der Text inkl. Passungen und ober/untertolleranzen extrahiert. Danach wird es an Excel übergeben, wo alles auf einem Formular landet. Siehe Screenshot der extrahiere Daten.
Jetzt will ich das gleiche auch noch in Inventor erstellen.
Pos.Nr., Textvorsatz, Art(Ø, R oder Winkel), Bemaßungswert, Passung, ob.Toleranz, unt.Toleranz

Ich kann im Inventor an die Eigenschaften der einzelnen Bemaßungen kommen, nur ist es etwas unglücklich gemacht.
Z.B. der Wert von "FormatedText" ist "Flansch <DimensionValue/>" und bei "Text" steht "Flansch n200" wobei das "n" füt das Durchmesserzeichen steht.
Gibt es eine Möglichkeit mit der ich den Wert von "<DimensionValue/>" abfragen kann?
Eventuel auch noch um welche Art von Bemaßung es sich handelt. Radius, Durchmesser, Winkel oder Linie.
ICh bräuchte alle Werte getrennt von einander.

[Diese Nachricht wurde von insidERR am 25. Sep. 2017 editiert.]

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Hallo,

am Besten, du setzt einen Haltepunkt in VBA und schaust dir die Struktur an.

Wert von "<DimensionValue/>" abfragen kann?

Code:

---

ThisApplication.ActiveDocument.Sheets.Item(1).DrawingDimensions.Item(1).ModelValue

---

ist intern in cm. Somit *10 nehmen

Art von Bemaßung es sich handelt. Radius, Durchmesser, Winkel oder Linie:

Code:

---

ThisApplication.ActiveDocument.Sheets.Item(1).DrawingDimensions.Item(1).type
kDiameterGeneralDimensionObject = Duchmesser
kOrdinateDimensionObject = Koordinatenbemassung

---

------------------
Gruß Roland

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Hallo Roland,
danke für deinen Beitrag.
Hatte die Werte schon entdeckt. War nur nicht sicher, ob man ModelValue immer *10 nehmen kann, oder der Skallierfaktor sich ändern kann. Dachte, es gibt vielleicht eine bessere Lösung.

Nun gut. Nach 2 Tagen Fummelei habe ich folgenden Code gebastelt, der genau das ausgibt was ich brauche.

Code:

---

Public Function getPrüfmaße(Optional AutoNummerierung As Boolean, Optional MsgBoxAusgabe As Boolean) As String '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
  Set oDrawDoc = ThisApplication.ActiveDocument
 
  For i = 1 To oDrawDoc.ActiveSheet.DrawingDimensions.Count 'alle Bemaßungen durchlaufen
    If oDrawDoc.ActiveSheet.DrawingDimensions(i).IsInspectionDimension = True Then 'wenn Bemaßung = Prüfbemaßung dann...
        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
       
      '### Eigenschaften der "Prüfbemaßung" (Form, Pos) auslesen
        Call oDrawDoc.ActiveSheet.DrawingDimensions(i).GetInspectionDimensionData(Shape, Pos, PrüfRate)
       
      '### 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
    End If
  Next i
 
'### Rückgabewert
  getPrüfmaße = 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

---

Falls einer den Code hier gebrauchen kann, wären ein kurzer Kommentar hier willkommen :-)

[Diese Nachricht wurde von insidERR am 27. Sep. 2017 editiert.]

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP