---

Schraffur.jpg

Hallo zusammen,

irgendwie führt eins zum anderen, von daher hätte ich hier noch eine Frage an euch:

Wieso liegt meine Schraffur nicht in der durch die Polylinie begrenzten Fläche? 

wenn ich das ganze manuell mache, will heißen:

-Polylinie erstellen
-BKS ändern
-Schraffur ändern
-BKS zurücksetzen

=> fertig 

dann läuft das ja auch,

aber wenn ich das ganze über VBA versuche, dann wird die Schraffur zwar erstellt, allerdings nicht in meiner Polylinie, sondern auf einer etwas tiefer gelegenen paralellen Ebene. 

warum ist das so?
und wie kann ich dafür sorgen dass die Schraffur auch wirklich in meiner Polylinie erstellt wird?

hier mein Code:

Public Sub SchraffurIV()

Dim Eckpunkte(0 To 14) As Double

Dim hatchObj As AcadHatch

Dim temp(0 To 0) As AcadEntity

Eckpunkte(0) = 2: Eckpunkte(1) = 7: Eckpunkte(2) = 6
Eckpunkte(3) = 17: Eckpunkte(4) = 7: Eckpunkte(5) = 6
Eckpunkte(6) = 17: Eckpunkte(7) = 1: Eckpunkte(8) = 3
Eckpunkte(9) = 2: Eckpunkte(10) = 1: Eckpunkte(11) = 3
Eckpunkte(12) = 2: Eckpunkte(13) = 7: Eckpunkte(14) = 6

    ThisDrawing.ModelSpace.Add3DPoly (Eckpunkte)
   
    Dim UCSColl As AcadUCSs
    Set UCSColl = ThisDrawing.UserCoordinateSystems
   
    Dim ucsObj As AcadUCS
    Dim origin(0 To 2) As Double
    Dim xAxisPnt(0 To 2) As Double
    Dim yAxisPnt(0 To 2) As Double
   
    origin(0) = 2#: origin(1) = 7#: origin(2) = 6#
    xAxisPnt(0) = 17#: xAxisPnt(1) = 7#: xAxisPnt(2) = 6#
    yAxisPnt(0) = 2#: yAxisPnt(1) = 1#: yAxisPnt(2) = 3#
   
    Set ucsObj = UCSColl.Add(origin, xAxisPnt, yAxisPnt, "TEST")
   
    ThisDrawing.ActiveUCS = ucsObj
   

Set hatchObj = ThisDrawing.ModelSpace.AddHatch(0, "Solid", True)
Set temp(0) = ThisDrawing.ModelSpace.Add3DPoly(Eckpunkte)
hatchObj.AppendOuterLoop (temp)
hatchObj.color = acRed
hatchObj.Evaluate

'Und hier setze ich dann das BKS zurück.

Dim UCSCollwelt As AcadUCSs

    Set UCSCollwelt = ThisDrawing.UserCoordinateSystems
   
    Dim ucsObjwelt As AcadUCS
    Dim originwelt(0 To 2) As Double
    Dim xAxisPntwelt(0 To 2) As Double
    Dim yAxisPntwelt(0 To 2) As Double
   
    originwelt(0) = 0#: originwelt(1) = 0#: originwelt(2) = 0#
    xAxisPntwelt(0) = 1#: xAxisPntwelt(1) = 0#: xAxisPntwelt(2) = 0#
    yAxisPntwelt(0) = 0#: yAxisPntwelt(1) = 1#: yAxisPntwelt(2) = 0#
   
    Set ucsObjwelt = UCSColl.Add(originwelt, xAxisPntwelt, yAxisPntwelt, "Welt")
   
    ThisDrawing.ActiveUCS = ucsObjwelt

End Sub

Viele Grüße, Simon

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

---

Entschuldigung,

"Schraffur auf paralleler Ebene" muss es natürlich heißen. Ich war irgendwie so darauf bedacht in parallel die richtige Anzahl an "l"s reinzupacken dass mir das überschüssige "t" nicht aufgefallen ist... 

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

---

Hi,

interessante Sache 

Noch hab ich's nicht raus, aber für alle Mitsuchenden vielleicht mein aktuelles Zwischenergebnis:

Der Versatz der Schraffur liegt (in WCS gemessen) genau um 0,-1,2 verschoben. Das ist zwar ein Zahlenwert, mit dem ich bis jetzt noch nichts anfangen kann, aber ev. sieht wer anderer Zusammenhänge mit den Koordinaten.

- alfred -

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

---

Hi,

ich hab keinen blassen Schimmer, wieso das passiert (mit 2010 und mit 2009 hätt ich's probiert). Ich kann Dir nur ein Workaround anbieten:

Die Extents der 3DPoly und der Schraffur vergleichen und die Schraffur dann hinschieben:

Code:

---

  Dim tExtMin1 As Variant
  Dim tExtMax1 As Variant
  Dim tExtMin2 As Variant
  Dim tExtMax2 As Variant
 
  Call t3DPoly.GetBoundingBox(tExtMin1, tExtMax1)
  Call hatchObj.GetBoundingBox(tExtMin2, tExtMax2)
  Call hatchObj.Move(tExtMin2, tExtMin1)

---

Änderungen, die Du in Deinem Code noch durchführen solltest:

a) die Poly braucht nur 4 Punkte, sollte dann aber geschlossen werden
b) Du erzeugst die Poly zwei mal (einmal als Poly und dann nochmals als Grenze der Schraffur), macht nur Geometrie umsonst, hat keinen Sinn (imho).

Mein Schnippsel sieht nach den Modifikationen so aus:

Code:

---

Public Sub SchraffurIV()

  Dim Eckpunkte(0 To 11) As Double
  Dim hatchObj As AcadHatch
  Dim temp(0 To 0) As AcadEntity
  Dim t3DPoly As Acad3DPolyline
  Dim ucsObj As AcadUCS
  Dim origin(0 To 2) As Double
 
  Eckpunkte(0) = 2: Eckpunkte(1) = 7: Eckpunkte(2) = 6
  Eckpunkte(3) = 17: Eckpunkte(4) = 7: Eckpunkte(5) = 6
  Eckpunkte(6) = 17: Eckpunkte(7) = 1: Eckpunkte(8) = 3
  Eckpunkte(9) = 2: Eckpunkte(10) = 1: Eckpunkte(11) = 3
  'Eckpunkte(12) = 2: Eckpunkte(13) = 7: Eckpunkte(14) = 6
 
  Set t3DPoly = ThisDrawing.ModelSpace.Add3DPoly(Eckpunkte)
  t3DPoly.Closed = True
 
  Dim UCSColl As AcadUCSs
  Set UCSColl = ThisDrawing.UserCoordinateSystems
 
  Dim xAxisPnt(0 To 2) As Double
  Dim yAxisPnt(0 To 2) As Double
 
  origin(0) = 2#: origin(1) = 7#: origin(2) = 6#
  xAxisPnt(0) = 17#: xAxisPnt(1) = 7#: xAxisPnt(2) = 6#
  yAxisPnt(0) = 2#: yAxisPnt(1) = 1#: yAxisPnt(2) = 3#
 
  Set ucsObj = UCSColl.Add(origin, yAxisPnt, xAxisPnt, "TEST")
  ThisDrawing.ActiveUCS = ucsObj
 
  Set temp(0) = t3DPoly
 
  Set hatchObj = ThisDrawing.ModelSpace.AddHatch(0, "Solid", True)
  Call hatchObj.AppendOuterLoop(temp)
  hatchObj.color = acRed
  hatchObj.Evaluate
 
  Dim tExtMin1 As Variant
  Dim tExtMax1 As Variant
  Dim tExtMin2 As Variant
  Dim tExtMax2 As Variant
 
  Call t3DPoly.GetBoundingBox(tExtMin1, tExtMax1)
  Call hatchObj.GetBoundingBox(tExtMin2, tExtMax2)
  Call hatchObj.Move(tExtMin2, tExtMin1)
End Sub

---

- alfred -

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

---

Super, Danke, jetzt sollte das Ding halbwegs laufen! 

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