Hot News:

Unser Angebot:

  Foren auf CAD.de (alle Foren)
  Inventor VBA
  RangeBox einen Tick zu groß

Antwort erstellen  Neues Thema erstellen
CAD.de Login | Logout | Profil | Profil bearbeiten | Registrieren | Voreinstellungen | Hilfe | Suchen

Anzeige:

Darstellung des Themas zum Ausdrucken. Bitte dann die Druckfunktion des Browsers verwenden. | Suche nach Beiträgen nächster neuer Beitrag | nächster älterer Beitrag
  
Gut zu wissen: Hilfreiche Tipps und Tricks aus der Praxis prägnant, und auf den Punkt gebracht für Autodesk Produkte
Autor Thema:  RangeBox einen Tick zu groß (2160 mal gelesen)
rkauskh
Moderator
Dipl.-Ing. (FH) Versorgungstechnik




Sehen Sie sich das Profil von rkauskh an!   Senden Sie eine Private Message an rkauskh  Schreiben Sie einen Gästebucheintrag für rkauskh

Beiträge: 2166
Registriert: 15.11.2006

Windows 10 x64, AIP 2022

erstellt am: 03. Jun. 2009 12:30    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities


DrawRangeBox.jpg

 
Hallo

Das unten stehende Makro zeichnet eine RangeBox um eine Baugruppe und gibt die Abmessungen dieser aus. Leider werden Ursprungsachsen mit einbezogen (s. Screenshot), was natürlich totalen Unfug ergibt. Es ist unabhängig davon, ob die Ursprungsachsen sichtbar sind oder nicht.

Gibt es dafür Abhilfe? Kann man die RangeBox irgendwie "reseten"? So kann man mit den ermittelten Werten eigentlich nix anfangen.

Code:
Public Sub DrawRangeBox()


    Dim oDoc As Document
    Set oDoc = ThisApplication.ActiveDocument

    ' Set a reference to component definition of the active document.
    ' This assumes that a part or assembly document is active.
    Dim oCompDef As ComponentDefinition
    Set oCompDef = ThisApplication.ActiveDocument.ComponentDefinition

    ' Make sure something is selected.
    If oDoc.SelectSet.Count = 0 Then
        MsgBox "Bitte vorher Baugruppe auswählen."

        ' Delete any graphics, if they exist.
        On Error Resume Next
        Dim oExistingGraphicsData As GraphicsDataSets
        Set oExistingGraphicsData = oDoc.GraphicsDataSetsCollection.Item("RangeBoxGraphics")
        If Err.Number = 0 Then
            On Error GoTo 0
            Dim oExistingGraphics As ClientGraphics
            Set oExistingGraphics = oCompDef.ClientGraphicsCollection.Item("RangeBoxGraphics")
            oExistingGraphics.Delete
            oExistingGraphicsData.Delete
            ThisApplication.ActiveView.Update
        End If

        Exit Sub
    End If

    ReDim aoRanges(1 To oDoc.SelectSet.Count) As Box
    Dim iRangeCount As Long
    Dim i As Long
    On Error Resume Next
    For i = 1 To oDoc.SelectSet.Count
      Dim oBox As Box
        Set oBox = oDoc.SelectSet.Item(i).RangeBox
        If Err Then
            Err.Clear
            ' Special case for B-Rep entities.
            If oDoc.SelectSet.Item(i).Type = kFaceObject Or _
              oDoc.SelectSet.Item(i).Type = kFaceProxyObject Or _
              oDoc.SelectSet.Item(i).Type = kEdgeObject Or _
              oDoc.SelectSet.Item(i).Type = kEdgeProxyObject Then
                ' Get the range from evaluator of the BRep object.
                Set oBox = oDoc.SelectSet.Item(i).Evaluator.RangeBox
                iRangeCount = iRangeCount + 1
                Set aoRanges(iRangeCount) = oBox
            End If
        Else
            iRangeCount = iRangeCount + 1
            Set aoRanges(iRangeCount) = oBox
        End If
    Next
    On Error GoTo 0

    If iRangeCount = 0 Then
        MsgBox "You must pick object(s) that support a 3D RangeBox property."
        Exit Sub
    End If

    ' Check to see if range box graphics information already exists.
    On Error Resume Next
    Dim oClientGraphics As ClientGraphics
    Dim oLineGraphics As LineGraphics
    Dim oBoxNode As GraphicsNode
    Dim oGraphicsData As GraphicsDataSets
    Set oGraphicsData = oDoc.GraphicsDataSetsCollection.Item("RangeBoxGraphics")
    If Err Then
        Err.Clear
        On Error GoTo 0

        ' Set a reference to the transient geometry object for user later.
        Dim oTransGeom As TransientGeometry
        Set oTransGeom = ThisApplication.TransientGeometry

        ' Create a graphics data set object. This object contains all of the
        ' information used to define the graphics.
        Dim oDataSets As GraphicsDataSets
        Set oDataSets = oDoc.GraphicsDataSetsCollection.Add("RangeBoxGraphics")

        ' Create a coordinate set.
        Dim oCoordSet As GraphicsCoordinateSet
        Set oCoordSet = oDataSets.CreateCoordinateSet(1)

        ' Create the client graphics for this compdef.
        Set oClientGraphics = oCompDef.ClientGraphicsCollection.Add("RangeBoxGraphics")

        ' Create a graphics node.
        Set oBoxNode = oClientGraphics.AddNode(1)
        oBoxNode.Selectable = False

        ' Create line graphics.
        Set oLineGraphics = oBoxNode.AddLineGraphics

        oLineGraphics.CoordinateSet = oCoordSet
    Else
        Set oCoordSet = oGraphicsData.ItemById(1)
        Set oBoxNode = oCompDef.ClientGraphicsCollection.Item("RangeBoxGraphics").ItemById(1)
    End If

    Dim dBoxLines() As Double
    ReDim dBoxLines(1 To 12 * 6 * iRangeCount) As Double
    For i = 0 To iRangeCount - 1
        Dim MinPoint(1 To 3) As Double
        Dim MaxPoint(1 To 3) As Double
        Call aoRanges(i + 1).GetBoxData(MinPoint, MaxPoint)

        ' Line 1
        dBoxLines(i * 72 + 1) = MinPoint(1)
        dBoxLines(i * 72 + 2) = MinPoint(2)
        dBoxLines(i * 72 + 3) = MinPoint(3)
        dBoxLines(i * 72 + 4) = MaxPoint(1)
        dBoxLines(i * 72 + 5) = MinPoint(2)
        dBoxLines(i * 72 + 6) = MinPoint(3)

        ' Line 2
        dBoxLines(i * 72 + 7) = MinPoint(1)
        dBoxLines(i * 72 + 8) = MinPoint(2)
        dBoxLines(i * 72 + 9) = MinPoint(3)
        dBoxLines(i * 72 + 10) = MinPoint(1)
        dBoxLines(i * 72 + 11) = MaxPoint(2)
        dBoxLines(i * 72 + 12) = MinPoint(3)

        ' Line 3
        dBoxLines(i * 72 + 13) = MinPoint(1)
        dBoxLines(i * 72 + 14) = MinPoint(2)
        dBoxLines(i * 72 + 15) = MinPoint(3)
        dBoxLines(i * 72 + 16) = MinPoint(1)
        dBoxLines(i * 72 + 17) = MinPoint(2)
        dBoxLines(i * 72 + 18) = MaxPoint(3)

        ' Line 4
        dBoxLines(i * 72 + 19) = MaxPoint(1)
        dBoxLines(i * 72 + 20) = MaxPoint(2)
        dBoxLines(i * 72 + 21) = MaxPoint(3)
        dBoxLines(i * 72 + 22) = MinPoint(1)
        dBoxLines(i * 72 + 23) = MaxPoint(2)
        dBoxLines(i * 72 + 24) = MaxPoint(3)

        ' Line 5
        dBoxLines(i * 72 + 25) = MaxPoint(1)
        dBoxLines(i * 72 + 26) = MaxPoint(2)
        dBoxLines(i * 72 + 27) = MaxPoint(3)
        dBoxLines(i * 72 + 28) = MaxPoint(1)
        dBoxLines(i * 72 + 29) = MinPoint(2)
        dBoxLines(i * 72 + 30) = MaxPoint(3)

        ' Line 6
        dBoxLines(i * 72 + 31) = MaxPoint(1)
        dBoxLines(i * 72 + 32) = MaxPoint(2)
        dBoxLines(i * 72 + 33) = MaxPoint(3)
        dBoxLines(i * 72 + 34) = MaxPoint(1)
        dBoxLines(i * 72 + 35) = MaxPoint(2)
        dBoxLines(i * 72 + 36) = MinPoint(3)

        ' Line 7
        dBoxLines(i * 72 + 37) = MinPoint(1)
        dBoxLines(i * 72 + 38) = MaxPoint(2)
        dBoxLines(i * 72 + 39) = MinPoint(3)
        dBoxLines(i * 72 + 40) = MaxPoint(1)
        dBoxLines(i * 72 + 41) = MaxPoint(2)
        dBoxLines(i * 72 + 42) = MinPoint(3)

        ' Line 8
        dBoxLines(i * 72 + 43) = MinPoint(1)
        dBoxLines(i * 72 + 44) = MaxPoint(2)
        dBoxLines(i * 72 + 45) = MinPoint(3)
        dBoxLines(i * 72 + 46) = MinPoint(1)
        dBoxLines(i * 72 + 47) = MaxPoint(2)
        dBoxLines(i * 72 + 48) = MaxPoint(3)

        ' Line 9
        dBoxLines(i * 72 + 49) = MaxPoint(1)
        dBoxLines(i * 72 + 50) = MinPoint(2)
        dBoxLines(i * 72 + 51) = MaxPoint(3)
        dBoxLines(i * 72 + 52) = MaxPoint(1)
        dBoxLines(i * 72 + 53) = MinPoint(2)
        dBoxLines(i * 72 + 54) = MinPoint(3)

        ' Line 10
        dBoxLines(i * 72 + 55) = MaxPoint(1)
        dBoxLines(i * 72 + 56) = MinPoint(2)
        dBoxLines(i * 72 + 57) = MaxPoint(3)
        dBoxLines(i * 72 + 58) = MinPoint(1)
        dBoxLines(i * 72 + 59) = MinPoint(2)
        dBoxLines(i * 72 + 60) = MaxPoint(3)

        ' Line 11
        dBoxLines(i * 72 + 61) = MinPoint(1)
        dBoxLines(i * 72 + 62) = MinPoint(2)
        dBoxLines(i * 72 + 63) = MaxPoint(3)
        dBoxLines(i * 72 + 64) = MinPoint(1)
        dBoxLines(i * 72 + 65) = MaxPoint(2)
        dBoxLines(i * 72 + 66) = MaxPoint(3)

        ' Line 12
        dBoxLines(i * 72 + 67) = MaxPoint(1)
        dBoxLines(i * 72 + 68) = MinPoint(2)
        dBoxLines(i * 72 + 69) = MinPoint(3)
        dBoxLines(i * 72 + 70) = MaxPoint(1)
        dBoxLines(i * 72 + 71) = MaxPoint(2)
        dBoxLines(i * 72 + 72) = MinPoint(3)
    Next

    ' Assign the points into the coordinate set.
    Call oCoordSet.PutCoordinates(dBoxLines)

    ' Update the display.
    ThisApplication.ActiveView.Update
     
' Create a string that defines an area using the current length unit.
    Dim oUOM As UnitsOfMeasure
    Set oUOM = ThisApplication.ActiveDocument.UnitsOfMeasure
 
  ' Get the enum value that defines the current default length units.
    Dim eLengthUnit As UnitsTypeEnum
    eLengthUnit = oUOM.LengthUnits

    ' Get the equivalent string of the enum value.
    Dim sLengthUnit As String
    sLengthUnit = " " & oUOM.GetStringFromType(eLengthUnit)
         
    Dim sLaenge As String
    Dim sBreite As String
    Dim sHoehe As String
         
    Dim rLaenge As Double
    rLaenge = (MaxPoint(1) - MinPoint(1)) * 10
    sLaenge = Format$(rLaenge, "##0")
       
    Dim rBreite As Double
    rBreite = (MaxPoint(2) - MinPoint(2)) * 10
    sBreite = Format$(rBreite, "##0")
       
    Dim rHoehe As Double
    rHoehe = (MaxPoint(3) - MinPoint(3)) * 10
    sHoehe = Format$(rHoehe, "##0")
    MsgBox "Länge: " & sLaenge & sLengthUnit & Chr(13) & Chr(10) & "Breite: " & sBreite & sLengthUnit & Chr(13) & Chr(10) & "Höhe: " & sHoehe & sLengthUnit
   
    sLaenge = Replace(sLaenge, ",", ".", vbTextCompare)
    sBreite = Replace(sBreite, ",", ".", vbTextCompare)
    sHoehe = Replace(sHoehe, ",", ".", vbTextCompare)
   
    'Benutzerdefinierten Eintrag erzeugen
    'Länge vorhanden?
    Dim bLaengeDa As Boolean
    Dim oProp As Property
    bLaengeDa = False
    For Each oProp In oDoc.PropertySets("{D5CDD505-2E9C-101B-9397-08002B2CF9AE}")  'Benutzerdefiniert
        If oProp.Name = "Laenge" Then
            bLaengeDa = True
            Exit For
        End If
    Next
    'Länge eintragen oder ändern
    If bLaengeDa Then
        oDoc.PropertySets("{D5CDD505-2E9C-101B-9397-08002B2CF9AE}").Item("Laenge").Value = sLaenge
    Else
        oDoc.PropertySets("{D5CDD505-2E9C-101B-9397-08002B2CF9AE}").Add sLaenge, "Laenge"
    End If
   
        'Breite vorhanden?
    Dim bBreiteDa As Boolean
    bBreiteDa = False
    For Each oProp In oDoc.PropertySets("{D5CDD505-2E9C-101B-9397-08002B2CF9AE}")  'Benutzerdefiniert
        If oProp.Name = "Breite" Then
            bBreiteDa = True
            Exit For
        End If
    Next
    'Breite eintragen oder ändern
    If bBreiteDa Then
        oDoc.PropertySets("{D5CDD505-2E9C-101B-9397-08002B2CF9AE}").Item("Breite").Value = sBreite
    Else
        oDoc.PropertySets("{D5CDD505-2E9C-101B-9397-08002B2CF9AE}").Add sBreite, "Breite"
    End If
   
    'Höhe vorhanden?
    Dim bHoeheDa As Boolean
    bHoeheDa = False
    For Each oProp In oDoc.PropertySets("{D5CDD505-2E9C-101B-9397-08002B2CF9AE}")  'Benutzerdefiniert
        If oProp.Name = "Hoehe" Then
            bHoeheDa = True
            Exit For
        End If
    Next
    'Höhe eintragen oder ändern
    If bHoeheDa Then
        oDoc.PropertySets("{D5CDD505-2E9C-101B-9397-08002B2CF9AE}").Item("Hoehe").Value = sHoehe
    Else
        oDoc.PropertySets("{D5CDD505-2E9C-101B-9397-08002B2CF9AE}").Add sHoehe, "Hoehe"
    End If
   
   
    'Da die ClientGraphic nur temporär sein soll, wird sie nach Bestätigen
    'der Meldung wieder gelöscht.
    If oDoc.SelectSet.Count = 0 Then
   
    ' Delete any graphics, if they exist.
    On Error Resume Next
    Set oExistingGraphicsData = oDoc.GraphicsDataSetsCollection.Item("RangeBoxGraphics")
    If Err.Number = 0 Then
        On Error GoTo 0
        Set oExistingGraphics = oCompDef.ClientGraphicsCollection.Item("RangeBoxGraphics")
        oExistingGraphics.Delete
        oExistingGraphicsData.Delete
        ThisApplication.ActiveView.Update
    End If

    Exit Sub
    End If
End Sub


------------------
MfG
RK

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

Doc Snyder
Ehrenmitglied V.I.P. h.c.
Dr.-Ing. Maschinenbau, Entwicklung & Konstruktion von Spezialmaschinen



Sehen Sie sich das Profil von Doc Snyder an!   Senden Sie eine Private Message an Roland Schröder  Schreiben Sie einen Gästebucheintrag für Roland Schröder

Beiträge: 13115
Registriert: 02.04.2004

AIP2013SP2.2 XPproSP2 MS-IntelliMouse-Optical SpacePilot
DellM4600 2,13GHz 2GB FxGo1400 1920x1200
am Dock Dell2711

erstellt am: 03. Jun. 2009 12:43    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities Nur für rkauskh 10 Unities + Antwort hilfreich

"Größe automatisch ändern" abschalten?

------------------
Roland  
www.Das-Entwicklungsbuero.de

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

rkauskh
Moderator
Dipl.-Ing. (FH) Versorgungstechnik




Sehen Sie sich das Profil von rkauskh an!   Senden Sie eine Private Message an rkauskh  Schreiben Sie einen Gästebucheintrag für rkauskh

Beiträge: 2166
Registriert: 15.11.2006

Windows 10 x64, AIP 2022

erstellt am: 03. Jun. 2009 14:15    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities

Hallo

Nein, leider keine Änderung. Jedenfalls nicht mehr nachträglich.
In einer neuen Baugruppe funktioniert es auch mit "Größe automatisch ändern". Ist doch zum Verrückt werden. Wo ist denn die Ursache für so unterschiedliches Verhalten? 
Lösch ich alle Bauteile aus der alten BG raus und setz sie wieder rein, klappts auch wieder.

------------------
MfG
RK

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

Anzeige.:

Anzeige: (Infos zum Werbeplatz >>)

Darstellung des Themas zum Ausdrucken. Bitte dann die Druckfunktion des Browsers verwenden. | Suche nach Beiträgen

nächster neuerer Beitrag | nächster älterer Beitrag
Antwort erstellen


Diesen Beitrag mit Lesezeichen versehen ... | Nach anderen Beiträgen suchen | CAD.de-Newsletter

Administrative Optionen: Beitrag schliessen | Archivieren/Bewegen | Beitrag melden!

Fragen und Anregungen: Kritik-Forum | Neues aus der Community: Community-Forum

(c)2023 CAD.de | Impressum | Datenschutz