---

Bemasung.jpg

Hallo VBAler,

ich habe ein Makro geschrieben, dass in einer Skizze einer ipt die markierten Bemaßungen mit der Toleranz "H7" bzw "f7" ergänzt.
Wie im Bild links zu sehen, ist das Maß zunächst ohne Toleranz. Dann markiere ich (mehrere) Maße und starte das Makro, dass zuerst die markierten Objekte nach zulässigen Bemaßungen durchsucht und diese auf eben "H7" bzw. "F7" setzt.

Bei den Toleranzfeldern habe ich ein Aktualisierungsproblem:
Die dargestellte Toleranz ist 1/10 so groß wie in Wirklichkeit nötig OBWOHL die anschließend geöffneten 'Bemaßungseigenschaften' (Kontextmenü) den richtigen Wert ausweisen.

Interessanterweise: Wenn ich im Fenster 'Bemaßungseigenschaften' die Toleranz erneut wähle, wird die Skizze auf die richtige Toleranz hin aktualiert. Schließe ich das Fenster 'Bemaßungseigenschaften' ohne Neuauswahl, bleibt die falsche Toleranz sichtbar.

Wie aktualisiere ich die Bemaßung? Oder die Skizze?

Danke für Euren Tipp...
Stefan

PS.: Ich habe zu Testzwecken zusätzlich eine Maßveränderung um 0.1 bzw 0.01cm hinzugenommen, um zu sehen, dass das Makro auch die Werte ändert und was genau (nicht = die Skizze) aktualisiert wird.

Code:

---

Public Sub H7()
    Dim oSelectedObject
    Dim oOffsetDimConstr As OffsetDimConstraint
    Dim oTwoPointDistanceDimConstr As TwoPointDistanceDimConstraint
   
   
    Dim oc As ObjectCollection
    Set oc = ThisApplication.TransientObjects.CreateObjectCollection
    For Each oSelectedObject In ThisApplication.ActiveDocument.SelectSet
        If oSelectedObject.Type = kOffsetDimConstraintObject Or _
                oSelectedObject.Type = kTwoPointDistanceDimConstraintObject Then
            oc.Add oSelectedObject
        End If
    Next
    For Each oSelectedObject In oc
        If oSelectedObject.Type = kOffsetDimConstraintObject Then
            Set oOffsetDimConstr = oSelectedObject
            Call oOffsetDimConstr.Parameter.Tolerance.SetToDefault
            Call oOffsetDimConstr.Parameter.Tolerance.SetToSymmetric(0.05)
            oOffsetDimConstr.Parameter.Value = oOffsetDimConstr.Parameter.Value + 0.1
            Call oOffsetDimConstr.Parameter.Tolerance.SetToFits(kLimitsFitsShowTolerance, "H7", "")
        End If
        If oSelectedObject.Type = kTwoPointDistanceDimConstraintObject Then
            Set oTwoPointDistanceDimConstr = oSelectedObject
            Call oTwoPointDistanceDimConstr.Parameter.Tolerance.SetToDefault
            oTwoPointDistanceDimConstr.Parameter.Value = oTwoPointDistanceDimConstr.Parameter.Value + 0.1
            Call oTwoPointDistanceDimConstr.Parameter.Tolerance.SetToFits(kLimitsFitsShowTolerance, "H7", "")
        End If
    Next
    Set oc = Nothing
End Sub

Public Sub f7()
    Dim oSelectedObject
    Dim oOffsetDimConstr As OffsetDimConstraint
    Dim oTwoPointDistanceDimConstr As TwoPointDistanceDimConstraint
   
   
    Dim oc As ObjectCollection
    Set oc = ThisApplication.TransientObjects.CreateObjectCollection
    For Each oSelectedObject In ThisApplication.ActiveDocument.SelectSet
        If oSelectedObject.Type = kOffsetDimConstraintObject Or _
                oSelectedObject.Type = kTwoPointDistanceDimConstraintObject Then
            oc.Add oSelectedObject
        End If
    Next
    For Each oSelectedObject In oc
        If oSelectedObject.Type = kOffsetDimConstraintObject Then
            Set oOffsetDimConstr = oSelectedObject
            Call oOffsetDimConstr.Parameter.Tolerance.SetToDefault
            oOffsetDimConstr.Parameter.Value = oOffsetDimConstr.Parameter.Value + 0.01
            Call oOffsetDimConstr.Parameter.Tolerance.SetToFits(kLimitsFitsShowTolerance, "", "f7")
        End If
        If oSelectedObject.Type = kTwoPointDistanceDimConstraintObject Then
            Set oTwoPointDistanceDimConstr = oSelectedObject
            Call oTwoPointDistanceDimConstr.Parameter.Tolerance.SetToDefault
            oTwoPointDistanceDimConstr.Parameter.Value = oTwoPointDistanceDimConstr.Parameter.Value + 0.01
            Call oTwoPointDistanceDimConstr.Parameter.Tolerance.SetToFits(kLimitsFitsShowTolerance, "", "f7")
        End If
    Next
    Set oc = Nothing
End Sub

---

------------------
IV2008

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

---

Hallo Leute,

anbei meine Erkenntnisse:
  >> Inventor macht bei Toleranzfeldern echt einen Fehler!
und das Ergebnis meiner mühsamen Versuche:
  >> Makro öffnet Dialog, setzt die Einstellungen und schließt denselben, also ein kurzes Aufflackern und die Tolerenz ist gesetzt 

Wer es schöner kann, gerne posten...

Code:

---

Sub H9()
    Call toToleranzfeld("H9")
End Sub

Sub f7()
    Call toToleranzfeld("f7")
End Sub

Sub e8()
    Call toToleranzfeld("e8")
End Sub

' setzt auf Toleranzfeld
Private Sub toToleranzfeld(sToleranz As String)
    Dim oSelectedObject
    Dim lIndex As Long, lPos As Long
    Dim sFeld As String
    Dim lZahl As Long
    Dim oOffsetDimConstr As OffsetDimConstraint
    Dim oTwoPointDistanceDimConstr As TwoPointDistanceDimConstraint
    Dim oDiameterDimConstr As DiameterDimConstraint
   
    lIndex = 1
    For Each oSelectedObject In ThisApplication.ActiveDocument.SelectSet
        If Not (oSelectedObject.Type = kOffsetDimConstraintObject Or _
                oSelectedObject.Type = kTwoPointDistanceDimConstraintObject Or _
                oSelectedObject.Type = kDiameterDimConstraintObject) Or _
                lIndex > 1 Then
            Call ThisApplication.ActiveDocument.SelectSet.Remove(lIndex)
        Else
            lIndex = lIndex + 1
        End If
    Next
    If ThisApplication.ActiveDocument.SelectSet.count > 0 Then
        lZahl = 0
        lPos = 0
        While lZahl = 0
            lPos = lPos + 1
            lZahl = CLng(Val(Mid(sToleranz, lPos)))
        Wend
        sFeld = Left(sToleranz, lPos - 1)
        Select Case sFeld ' wenn Toleranzfelder mit gleichem Buchstaben hintereinander liegen
            Case "cd", "j", "za", "J", "ZA": lZahl = lZahl + 18 ' dann 18 weiterspringen
            Case "zb", "ZB": lZahl = lZahl + 36 ' analog
            Case "zc", "ZC": lZahl = lZahl + 54
        End Select
        AppActivate "Autodesk Inventor 2008", True
        Call ThisApplication.CommandManager.ControlDefinitions.Item("AppDimensionSettingsCtxCmd").Execute2(False)
        SendKeys "{TAB 6}"
        SendKeys "{HOME}" ' erstmal auf obersten Wert Setzen = Standard
        SendKeys "{DOWN 9}" ' nach 9x runter ist man bei Größengrenzwerte
        If sFeld = UCase(sFeld) Then ' wenn Großbuchstabe, dann H, E,... - Feld
            SendKeys "{TAB}"
            SendKeys "{HOME}" ' erstmal auf obersten Wert Setzen
            SendKeys Left(sFeld, 1) ' Toleranzfeld z.B. H
            If lZahl > 1 Then SendKeys "{DOWN " & (lZahl - 1) & "}" ' z.B. H7 = 6x runter
            SendKeys "{TAB 4}"
        Else ' Kleinbuchstabe, also f, e, ... -Feld
            SendKeys "{TAB 2}"
            SendKeys "{HOME}" ' erstmal auf obersten Wert Setzen
            SendKeys Left(sFeld, 1) ' Toleranzfeld z.B. f
            If lZahl > 1 Then SendKeys "{DOWN " & (lZahl - 1) & "}"  ' z.B. f8 = 7x runter
            SendKeys "{TAB 3}"
        End If
        SendKeys "{ENTER}" ' Übernehmen
        SendKeys "{ESC}"
    End If
End Sub

---

Vielleicht hilft dieser Code ja jemanden 

Danke für Eure Anteilnahme...
Stefan

------------------
IV2008

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

---

Hallo,

gibt es mittlerweile eine saubere Lösung für das Problem?

Gruß Donni

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