---

Kann mir jemand sagen, wie ich eine auswahl auf 0,0 verschieben kann?

folgenden Code habe ich:

Code:

---

Public Sub test_2()
    Dim sset As AcadSelectionSet
    Dim Entity As AcadEntity
    Dim fType%(1), fData(1)

    Dim minExt As Variant
    Dim maxExt As Variant
    Dim test As Variant
    Dim FromPoint  ', ToPoint
    Dim ToPoint(0 To 2) As Double

    On Error Resume Next
 
    Set sset = ThisDrawing.SelectionSets("Rahmen")
    If Err.Number Then
      Set sset = ThisDrawing.SelectionSets.Add("Rahmen")
    End If
    On Error GoTo 0
   
    fType(0) = 0
    fData(0) = "INSERT"
    fType(1) = 8  ' Layer
    fData(1) = "RAHMEN_EINGEFUEGT"
    fType(1) = 2  ' Blockname
    fData(1) = "NEW_BLOCK"
   
    sset.Select acSelectionSetAll, , , fType, fData
    For Each Entity In sset
        If Entity.ObjectName = "AcDbBlockReference" Then
       
        Entity.GetBoundingBox minExt, maxExt
       
        If minExt(0) <> "0" Then
       
          MsgBox " Nicht 0,0"
         
          On Error Resume Next
         
          Set sset = ThisDrawing.SelectionSets("ALLES")
         
          sset.Select acSelectionSetAll
         
          FromPoint = minExt
         
          ToPoint(0) = 0#
          ToPoint(1) = 0#
          ToPoint(2) = 0#
         
        For Each nItem In acSSet
          Entity.Move FromPoint, ToPoint
        Next
         
        End If
             
        End If
    Next
    sset.Delete
End Sub

---

Danke im voraus.

------------------
Gruß, Bernhard F.

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

---

Hi Bernhard,

bitte nochmals um Beschreibung, denn Dein Code schiebt alles mögliche (wobei mir auch nicht klar ist, woher 'acSSet' kommt (in Deiner inneren Schleife)).

Möchtest Du jedes einzelne Element Deines SelectionSets nach 0,0 (der Extents) verschieben?
Oder soll zuerst Extents des gesamten SelectionSets gebildet werden und dann der linke untere Punkt zu 0,0 werden?

Und ist die Ermittlung über Extents überhaupt richtig? Denn z.B. ein Text, der Mitte-Zentriert eingesetzt ist, wird dann so geschoben dass der 'markante Punkt' des Textes eben nicht auf 0,0 gelegt wird.

Und welchen Zweck hat die Prüfung  'If Entity.ObjectName = "AcDbBlockReference" Then',  denn das SelectionSet is ha schon mit Filter (Selektier nur BlockReferenzen) gebaut?

- alfred -

------------------
www.hollaus.at

---

Hallo alfred

Es soll ein gesamtes SelectionSets gebildet werden und der linke unter Punkt zu 0,0 werden.

------------------
Gruß, Bernhard F.

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

---

Hi,

blind geschrieben, also Tipfehler möglich (und kostenlos mitgeliefert )

Code:

---

Dim tEnt as AcadEntity
dim tAllMin(2) as Double:tAllMin(0) = 99999999.9:tAllMin(1) = 99999999.9:tAllMin(2) = 99999999.9

'zuerst sammeln wir die Min-Extents aller Elemente im SelectionSet
for each tEnt in sset
  Dim tEntMin as Variant
  Dim tEntMax as Variant
  Call tEnt.GetBoundingBox(tEntMin,tEntMax)
  if tEntMin(0) < tAllMin(0) then tAllMin(0) = tEntMin(0)
  if tEntMin(1) < tAllMin(1) then tAllMin(1) = tEntMin(1)
  if tEntMin(2) < tAllMin(2) then tAllMin(2) = tEntMin(2)
Next

'und jetzt verschieben wir alle Element um den MinPoint
dim tDestPnt(2) as double
For each tEnt in sset
  call tEnt.Move(tAllMin,tDestPnt)
Next

---

HTH, - alfred -

------------------
www.hollaus.at

---

Vielleicht etwas umständlich aber es funktioniert.

Code:

---

Public Sub Alles_Verschieben()
    Dim sset As AcadSelectionSet
    Dim Entity As AcadEntity
    Dim fType%(1), fData(1)

    Dim minExt As Variant
    Dim maxExt As Variant
    Dim Test As Variant
    Dim FromPoint  ', ToPoint
    Dim ToPoint(0 To 2) As Double

    On Error Resume Next
 
    Set sset = ThisDrawing.SelectionSets("Rahmen")
    If Err.Number Then
      Set sset = ThisDrawing.SelectionSets.Add("Rahmen")
    End If
    On Error GoTo 0
   
    fType(0) = 0
    fData(0) = "INSERT"
    fType(1) = 8  ' Layer
    fData(1) = "0"
    fType(1) = 2  ' Blockname
    fData(1) = "Ra1"
   
    sset.Select acSelectionSetAll, , , fType, fData
    For Each Entity In sset
   
    Call Entity.GetBoundingBox(minExt, maxExt)
       
        If minExt(0) <> "0" Then
       
          MsgBox " Nicht 0,0"
        Else
          Exit Sub
        End If
    Next
   
          On Error Resume Next
          Set sset = ThisDrawing.SelectionSets("ALLES")
         
          sset.Select acSelectionSetAll
         
          FromPoint = minExt
         
          ToPoint(0) = 0#
          ToPoint(1) = 0#
          ToPoint(2) = 0#
         
      For Each Entity In sset
          Entity.Move FromPoint, ToPoint
      Next
    sset.Delete
End Sub

---

------------------
Gruß, Bernhard F.

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

---

Hi,

kleine Bemerkung sei mir erlaubt:

Wenn mehrere BlockReferenzen mit dem Namen 'RA1' existieren, dann geht Dein Makro aber nur wenn der erste gefundene Block den X-Wert der Extents-Min <> 0.0 hat. Ist der vom ersten gefundenen Block der Extents-Min-X-Wert = 0, fliegt er aus der Sub raus.

Und das zweite ist auch schon mitgesagt, es wird nur der X-Wert überprüft, nicht Y und nicht Z.

- alfred -

------------------
www.hollaus.at