Antwort auf E-Mail-Anfrage vom 14.09.2003

Prozedur Rechteck zeichnen

Sub RechteckZeich()
Dim objRk As AcadPolyline
Dim objRk2 As AcadPolyline
Dim varPkt As Variant, varPkt2 As Variant, varPkt3 As Variant, varPkt4 As Variant

Dim plineObj As AcadPolyline
Dim dblPunkte(0 To 14) As Double

' Punkte definieren, besser über Dialogfenster
varPkt = ThisDrawing.Utility.GetPoint(, "Zeigen Sie den ersten Punkt")
varPkt3 = ThisDrawing.Utility.GetCorner(varPkt, "Zeigen Sie den oberen rechten Eckpunkt")

'Koordinatenpunkte in die Variable Punkteliste
'1. Punkt varPkt
'X
dblPunkte(0) = varPkt(0)
'Y
dblPunkte(1) = varPkt(1)
'Z
dblPunkte(2) = 0
'usw.
dblPunkte(3) = varPkt3(0): dblPunkte(4) = varPkt(1): dblPunkte(5) = 0
'3. Punkt
dblPunkte(6) = varPkt3(0): dblPunkte(7) = varPkt3(1): dblPunkte(8) = 0
'4. Punkt
dblPunkte(9) = varPkt(0): dblPunkte(10) = varPkt3(1): dblPunkte(11) = 0
'5. Punkt
dblPunkte(12) = varPkt(0): dblPunkte(13) = varPkt(1): dblPunkte(14) = 0

'Rechteck zeichnen
Set objRk = ThisDrawing.ModelSpace.AddPolyline(dblPunkte)
ZoomAll

End Sub

Was genau bewirken diese Zuweisungen??

Die 4 Punkte (mit X,Y,Z-Koordinate) werden in die Punkteliste eingetragen: Position des ersten Punktes: X = 0, Y=1, Z=2.

Die 4. Position in der Punkteliste ist der X-Wert des 2. Punktes.

0,1,2 ist die erste Koordinate,

3,4,5 die zweite (rechts unten),

6,7,8 die dritte (rechts oben),

9,10,11 die vierte (links oben) und

12,13,14 zumachen müssen wir das Rechteck auch wieder.

Da hätte man auch den Befehl schließen verwenden können.

Bei der Variablen dblPunkte handelt es sich um ein Array mit 15 (0 to 14) "Zellen".

Stell dir das als Exceltabelle mit einer Spalte und 15 Zeilen vor.

Immer 3 aufeinanderfolgende Zeilen beinhalten die Koordinaten eines Punktes.

Für die Polylinie müssen alle Punkte fortlaufend in einer Variablen gespeichert sein dblPunkte (0 to 14), darum übertrage ich die von den Variablen varPkt1 und VarPkt3 in die Punkteliste dblPunkte. Die Punkte 2 und 4 müssen berechnet werden und auch in die Punkteliste eingetragen werden. In der richtigen Reihenfolge, wie du die Punkte klicken würdest.

Die Variablen varPkt1 und VarPkt3 sind Arrays mit 3 Koordinaten: X, Y und Z-Koordinate des jeweils geklickten Punktes.

Die Koordinaten des ersten geklickten Punktes trage ich jetzt in die fortlaufende Punkteliste (dblPunkte) ein.

Hättest du einzelne Linien, hätte man sofort loslegen können, ohne die Punkte in die Punkteliste wegzuspeichern, da der Linienbefehl einzelne Punkte verlangt.

Der erste Punkt wurde gezeigt, also muss ich den X,Y und den Z-Wert aus der Variablen varPkt1 in die Punkteliste übertragen

dblPunkte(0) = varPkt1(0) ist x belegt in dblPunkte die "Zeile" 0

dblPunkte(1) = varPkt1(1) ist y belegt in dblPunkte die "Zeile" 1

dblPunkte(2) = varPkt1(2) ist z belegt in dblPunkte die "Zeile" 2

Für den Punkte 2 sieht das so aus (dblPunkte(3) bis dblPunkte(5):

dblPunkte(3) = varPkt3(0) = X-Wert vom 2. geklickten Punkt

dblPunkte(4) = varPkt(1) = Y-Wert vom 1. geklickten Punkt

dblPunkte(5) = 0 = Z-Wert

Funktion zum mehrfachen Kopieren von Objekten:

Public Sub kopieren()

Dim objDrawing As AcadEntity
Dim objCopiedObject As Object
Dim varEntinity As Variant
Dim dblPkt1(0 To 2) As Double
Dim dblPkt2(0 To 2) As Double

On Error Resume Next

dblPkt1(0) = 0#: dblPkt1(0) = 0#: dblPkt1(0) = 0#:
dblPkt2(0) = 0#: dblPkt2(0) = 0#: dblPkt2(0) = 0#:
'Schleife do ...

Dim varPruef As Variant

Set objDrawing = Nothing

varPruef = Null
ThisDrawing.Utility.GetEntity objDrawing, varEntinity, "Objekt wählen"

    If objDrawing Is Nothing Then
      MsgBox vbCr & "Kein Objekt gewählt" 'Dann Ausstieg
      Exit Sub
    End If

varPruef = objDrawing.ObjectName

Set objCopiedObject = objDrawing.Copy()

objCopiedObject.Move dblPkt1, dblPkt2
objCopiedObject.Update
objCopiedObject.Layer = 4

Loop Until IsNull(varPruef)

End Sub

'Die Ojektauflistung kannst du folgendermaßen durchlaufen:

Sub objListe()
Dim obj As AcadObject
Dim strListe As String

For Each obj In ThisDrawing.ModelSpace
strListe = strListe & vbLf & obj.ObjectName
Next

MsgBox strListe
End Sub

Verknüpfen eines Makros mit einer Schaltfläche

Neue Schaltfläche erstellen
Befehlsaufruf eintragen

Syntax: ^c^c_-vbarun;Makroname

Im Beispiel: ^c^c_-vbarun;objliste

'Farbe des Rechtecks ändern:

Sub RechteFarbe()
Dim objRk As AcadPolyline

Dim plineObj As AcadPolyline
Dim dblPunkte(0 To 14) As Double

' Punkte definieren, besser über Dialogfenster

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

'Rechteck zeichnen
Set objRk = ThisDrawing.ModelSpace.AddPolyline(dblPunkte)
ZoomAll

'Farbe ändern auf rot

objRk.Color = acRed

End Sub

'Oder im Stück, erstellen, kopieren, Farbe ändern

Sub RechteFarbe()

Dim objRk As AcadPolyline
Dim objRk2 As AcadPolyline
Dim plineObj As AcadPolyline
Dim dblPunkte(0 To 14) As Double

' Punkte definieren, besser über Dialogfenster

'Rechteck zeichnen

Set objRk = ThisDrawing.ModelSpace.AddPolyline(dblPunkte)
ZoomAll

'Kopie
Set objRk2 = objRk.Copy()

'Neue Position: Um 100 EH nach rechts kopiert
Dim dblP1(0 To 2) As Double, dblP2(0 To 2) As Double

dblP1(0) = 0: dblP1(1) = 0: dblP1(2) = 0
dblP2(0) = 100: dblP2(1) = 0: dblP2(2) = 0

objRk2.Move dblP1, dblP2

objRk.Color = acGreen
objRk2.Color = acRed

ZoomAll

End Sub