VBA für AutoCAD Teil 3

© Dipl.-Wirtsch.-Ing. Franz Ertl

Einleitung

Visual Basic for Applications oder kurz VBA ist eine Programmiersprache, die von Microsoft entwickelt wurde. Verschiedene Programmstrukturen wurden aus dem früheren Basic übernommen. Die Entwicklungsumgebung und die Art zu programmieren hat sich aber erheblich geändert. Ein Hauptvorteil gegenüber anderen Programmiersprachen ist die leichte Erlernbarkeit und die Integration in viele Programme. Mit VBA können Sie keine ausführbaren Programme erstellen. Sie können aber VBA-Routinen in Visual Basic übertragen. Die Sprachelemente von VB sind identisch mit denen von VBA. In VBA gibt es aber zusätzliche auf die jeweilige Anwendung bezogene Elemente. Zum Beispiel finden Sie in Microsoft Excel das Objekt „Cell“, das es in Autocad nicht gibt. In AutoCAD gibt es das Objekt Acad_Text, das es in Excel nicht gibt. Um in VB mit diesen Objekten arbeiten zu können, müssen Verweise erstellt werden. Sie erfahren mehr im Kapitel „Modul einfügen“.

Dieses Skript ist kein allumfassendes Nachschlagewerk, sondern eine Sammlung von Übungen, mit dem Ziel „VBA - Learning by doing“.

Verwenden Sie zur Vertiefung die Hilfe (Entwicklerhilfe).

Fortsetzung von Teil 2

Spline

Begrenzungspunkte	Array von Double-Zahlen, 3-dimensional, minimal 6 Elemente
Starttangente	Tangente am Startpunkt des Splines, 3D
Endtangente	Bestimmt die Tangente des Endpunkte, letzter Punkt 3D

Schraffur

Die Schraffur wird als einzelnes Objekt gespeichert. Wenn die Schraffur in den Ursprung zerlegt wird, ist das Schraffurobjekt zerstört. Übrig bleiben einzelne Objekte (Linien).

Text

Zum Beschriften von Zeichnungen wird das Text-Objekt verwendet. Es gibt eine Reihe von Parametern, um die Positionierung bzw. den Drehwinkel zu verändern.

MText

Das MText-Objekt bietet die Möglichkeit, umfangreichere Texte einzufügen. Der Vorteil liegt darin, dass das MTextobjekt, obwohl es mehrere Zeilen umfasst ein Objekt ist. Wird der Multitext in den Ursprung zerlegt, bleiben einzelne Zeilen als Text-Objekte übrig.

Punkt

Punkt werden beim Befehl Teilen oder Messen angeordnet. Die Form der Punkte ist über die Systemvariable PdMode einzustellen.

Im folgenden Beispiel wird eine Parabel gezeichnet. Stellen Sie nach dem Durchlauf der Funktion die Systemvariable PDMODE auf z.B. auf 33, um die Parabel zu sehen.

Übung: Polylinie

Die folgende Prozedur erstellt anstatt der Punkte eine Polylinie. Man muss dabei darauf achten, dass die Koordinaten in einem Array gespeichert werden. Die Punktezahl muss dabei decknungsgleich mit einem Mehrfachen von 3 sein – beginnend bei 0. Der Bereich beginnt bei 0 und beinhaltet 3 Werte: (0 to 2).

Polylinie mit Kreisbogen

Region

Auf Regionen können die Änderungsbefehle von 3D-Objekten z.B. DIFFERENZ, VEREINIG oder SCHNITTMENGE angewendet werden. Regionen sind aber nur zweidimensional.

Solid

Solids sind gefüllte Flächen bzw. „3D-Körper ohne Höhe“.

Daten aus Excel einlesen

Erstellen Sie die folgende Excel-Tabelle.

Speichern Sie diese unter dem Namen „vba_kreise.xls“.

Geben Sie die dargestellten Werte ein.

Erstellen Sie im VBA-Editor unter Extras / Verweise den Verweis auf die installierte Excel-Version.

Erstellen Sie die folgende Routine.

Die Routine holt Daten aus einer Excel-Tabelle und zeichnet 4 Kreise.

Erweitern Sie die Excel-Tabelle.

Aus den in Excel eingegebenen Punkten soll eine Polylinie erstellt werden.

Erweitern Sie dazu die oben erstellte Routine wie unten dargestellt.

Ändern von Objekten

Inhalte dieses Kapitels:

· Verschiedene Änderungsbefehle.

· Ändern der Objekteigenschaften.

· Ändern von 3D-Objekten.

Kopieren

Mit der Methode Kopieren können Sie eine Kopie von ausgewählten Objekten erzeugen.

Löschen

Die Lösch-Methode löscht ausgewählte Objekte.

Das nachfolgende Beispiel markiert nacheinander alle Kreise und fragt, ob der markierte Kreis gelöscht werden soll.

Auflösen

Mit der Methode Auflösen zerlegen Sie Polylinien, Blöcke, 3D-Körper usw. in den Ursprung. Vorsicht, z.B. bei Schraffuren und 3D-Körpern ist der Prozess nicht umkehrbar.

Die nachfolgende Routine ruft die Funktion PolylinieZeichnen (nächste Seite) auf. Danch wird die Polylinie in den Ursprung zerlegt und die Einzelteile werden hervorgehoben und mit einer Zählerschleife werden die einzelnen Objekte in unterschiedlichen Farben dargestellt. Beim ersten Schlefendurchlauf erhält das erste Objekt die Farbe 1, beim zweiten Durchlauf das zweite Objekt die Farbe 2 usw.

Die nachfolgende Funktion zeichnet eine Polylinie.

Hervorheben

Mit der Methode Hervorheben können Objekte gestrichelt angezeigt werden. Die Systemvariable HIGHLIGHT steuert, ob ausgewählte Objekte in AutoCAD gestrichelt dargestellt werden.

Spiegeln

Die Methode Spiegeln erstellt ein gespiegeltes Abbild der Auswahl. Sie haben die Möglichkeit, die Auswahl zu löschen und nur das Spiegelbild zu erhalten oder beide Objekte zu behalten.

Im Beispiel wird die vorher erstellte Polylinie geschlossen und dann gespiegelt.

Mirrtext

Die Systemvariable MirrText steuert, ob der Text mitgespiegelt wird oder nicht. Mirrtext = 1 spiegelt den Text.

Schieben

Die ausgewählten Objekte werden an eine Position verschoben.

Übung: Kreis erstellen und verschieben

Versetzen

Gewählte Objekte werden kopiert und im eingegebenen Abstand vom Originalobjekt eingefügt. Wenn Kreise versetzt werden, erhalten Sie konzentrische Kreise.

Bei Polylinien werden die Objekte nicht nur kopiert, sondern die Linienlängen angepasst.

Die Beispielprozedur ruft eine Funktion auf, die ein LightWeight-Polylinien-Objekt zurückgibt. Anschließend wird das Polylinienobjekt um 5 Einheiten versetzt. Die versetzte Polylinie wird rot gezeichnet.

Übung: Polylinie mit fest eingebenen Punkten.

Erweitern Sie die Funktion um die Option „Schließen“.

Drehen

Gewählte Objekte werden um einen bestimmten Winkel um einen Drehpunkt gedreht.

Die folgende Sub-Prozedur ruft die Funktion ZeichnenPolylinie auf, um eine Polylinie zu erstellen. Danach wird ein Winkelwert über die InputBox abgefragt. Der eingegebene Winkelwert wird dann in das Bogenmaß umgerechnet.

Die folgende Funktion rechnet den Bogenwert in einen Winkel um. Die Konstante Pi ist relativ genau.

Diese Funktion führt die Drehung aus und greift dabei auf die o. gezeigte Winkelumwandlung zu.

Die nachfolgende Funktion rechnet die eingegebenen Dezimalgrad in das Bogenmaß um.

Public Function Winkel2Rad(dblRad As Double) As Double

Winkel2Rad = dblRad * 3.14159265358979 / 180

End Function

Skalieren

Diese Methode erlaubt das proportionale verkleinern bzw. vergrößern von gewählten Objekten.

Nach dem Zeichnen der Polylinie über die Funktion ZeichnenPolylinie wird der Basispunkt für die Skalierung festgelegt und die Skalierung durchgeführt.

Diese Methode erlaubt das proportionale verkleinern bzw. vergrößern von gewählten Objekten.

Sub Beispiel_Skalieren()

Dim objPlinie As AcadLWPolyline

Dim dblbasis(0 To 2) As Double

Dim dblfaktor As Double

'2 mal die Funktion Polylinie aufrufen, einmal Originalgröße,

'einmal auf die Hälfte verkleinert

Set objPlinie = ZeichnenLwPolylinie

Set objPlinie = ZeichnenLwPolylinie

' Skalierung festlegen

dblbasis(0) = 100: dblbasis(1) = 100: dblbasis(2) = 0

dblfaktor = 0.5

'Skalierung durchführen

objPlinie.ScaleEntity dblbasis, dblfaktor

ZoomExtents 'Zoom Grenzen

End Sub

Reihe rechteckig

Der Befehl Reihe kopiert Objekte. Für die rechteckige Reihe geben Sie den Abstand der Objekte und die Anzahl der Zeilen und Spalten an.

Sub Example_ArrayRectangular()

Dim objKreis As AcadCircle

Set objKreis = KreisZeichnen

'rechteckige Reihe definieren

Dim lngZeilen As Long

Dim lngSpalten As Long

Dim lngEbenen As Long

Dim dblAbZeilen As Double

Dim dblAbSpalten As Double

Dim dblAbEbenen As Double

lngZeilen = 5

lngSpalten = 5

lngEbenen = 2

dblAbZeilen = 100

dblAbSpalten = 100

dblAbEbenen = 100

' Reihe erzeugen

Dim retObj As Variant

retObj = objKreis.ArrayRectangular(lngZeilen, lngSpalten, lngEbenen, dblAbZeilen, dblAbSpalten, dblAbEbenen)

ZoomExtents

End Sub

Reihe polar

Für die polare Reihe geben Sie das Zentrum der Drehung, die Anzahl der Objekte und den auszufüllenden Winkel an.

Sub PolareReihe()

Dim objKreis As AcadCircle

'Funktion Kreiszeichnen

Set objKreis = ZeichnenKreis

'Polare Reihe definieren

Dim intAnzahl As Integer

Dim dblWinkel As Double

Dim dblBasis(0 To 2) As Double

intAnzahl = 7

dblWinkel = 360 / 180 * 3.1415926 'Vollkreis

dblBasis(0) = 0#: dblBasis(1) = 50#: dblBasis(2) = 0#

Dim retObj As Variant

retObj = objKreis.ArrayPolar(intAnzahl, dblWinkel, dblBasis)

ZoomExtents

End Sub

Eigenschaften ändern

Mit den bisher besprochenen Methoden können Sie Objekte in der Geometrie oder Anordnung verändern. Die Methoden zum Ändern der Eigenschaften betreffen die Darstellung der Objekte.

Objektfarbe

Mit dieser Methode kann die Farbe einzelner Objekte geändert werden.

Im Beispiel werden mit Hilfe einer Schleife die Farben von 1 bis 7 durchlaufen.

Sub Beispiel_ObjektFarbe()

Dim plineObj As AcadPolyline

Dim inti As Integer

' Polylinie zeichnen

Dim dblPunkte(8) As Double

dblPunkte(0) = 50: dblPunkte(1) = 50: dblPunkte(2) = 0

dblPunkte(3) = 100: dblPunkte(4) = 50: dblPunkte(5) = 0

dblPunkte(6) = 100: dblPunkte(7) = 150: dblPunkte(8) = 0

ZoomAll

Set plineObj = ThisDrawing.ModelSpace.AddPolyline(dblPunkte)

For inti = 1 To 7 'Farbe über Zählerschleife setzen

PlineObj.Color = inti

ThisDrawing.Regen (True)

MsgBox "Jetzt sehen Sie die Farbe mit der Nummer " & inti

Next

plineObj.Color = 256 'vonLayer

End Sub

Layer-Eigenschaft

Mit der Layer-Methode können Sie gewählte Objekte auf einen anderen Layer legen.

Das folgende Beispiel erzeugt den Layer "Konstruktion_035" und weist ihm die Farbe rot zu. Danach wird ein Kreis gezeichnet und die Objekteigenschaft LAYER auf Konstruktion_035 gesetzt.

Sub Beispiele_Layer()

' Layer erzeugen

Dim objLayer As AcadLayer

Set objLayer = ThisDrawing.Layers.Add("Konstruktion_035")

objLayer.Color = acRed

' Kreis zeichnen

Dim objKreis As AcadCircle

Dim dblZentrum(0 To 2) As Double

Dim dblRadius As Double

dblZentrum(0) = 3: dblZentrum(1) = 3: dblZentrum(2) = 0

dblRadius = 1.5

Set objKreis = ThisDrawing.ModelSpace.AddCircle(dblZentrum, dblRadius)

ZoomAll

'die Eigenschaft Layer des Kreises auf Konstruktion_035 ändern

objKreis.Layer = "Konstruktion_035"

'Regenerieren

ThisDrawing.Regen (True)

End Sub

Linientyp-Eigenschaft

Sie können den Linientyp von Objekten ändern.

Die folgende Prozedur ruft zuerst die Funktion LinientypLaden auf, danach die Funktion LinieErzeugen und ändert dann die Linientyp-Eigenschaft der neu gezeichneten Linie.

Sub Beispiel_Linientyp()

Dim objLinie As AcadLine

LinientypLaden 'Funktion LinientypLaden aufrufen

Set objLinie = LinieErzeugen 'Funktion LinieErzeugen

'Linientyp ändern

objLinie.Linetype = "acad_iso02w100"

ZoomAll

End Sub

Funktion LinientypLaden:

Public Sub LinientypLaden()

Dim objLinie As AcadLineType

Dim blnGefunden As Boolean

blnGefunden = False

For Each objLinie In ThisDrawing.Linetypes

If StrComp(objLinie.Name, "Acad_Iso02W100", 1) = 0 Then

blnGefunden = True

Exit For

End If

Next

If Not (blnGefunden) Then ThisDrawing.Linetypes.Load "Acad_Iso02W100", "acad.lin"

End Sub

Funktion LinieErzeugen:

Function LinieErzeugen() As AcadLine

Dim dblStart(0 To 2) As Double

Dim dblEnde(0 To 2) As Double

dblStart(0) = 50: dblStart(1) = 50: dblStart(2) = 0

dblEnde(0) = 100: dblEnde(1) = 100: dblEnde(2) = 0

Set LinieErzeugen = ThisDrawing.ModelSpace.AddLine(dblStart, dblEnde)

End Function

Sichtbarkeit-Eigenschaft

Hier steuern Sie, welche Objekte sichtbar bzw. unsichtbar sind.

Die folgende Prozedur zeichnet eine Linie, und fragt dann über eine Dialogbox ab, ob die gezeichnete Linie sichtbar oder unsichtbar sein soll. Über die Schaltfläche Abbrechen beenden Sie die Prozedur.

Function Visible()

Dim objLinie As AcadLine

Set objLinie = LinieErzeugen ' FunktionLinieErzeugen aufrufen

DISPLAY:

Dim response As Integer

response = MsgBox("Linie anzeigen?", vbYesNoCancel)

Select Case response

Case vbYes

objLinie.Visible = True

Case vbNo

objLinie.Visible = False

Case vbCancel

Exit Function

End Select

ThisDrawing.Regen True

GoTo DISPLAY

End Function

Ändern von 3D-Objekten bzw. Regionen

Volumenkörper können nicht nur im Stück gezeichnet werden, sondern aus bestehenden Objekten erzeugt werden. Was Sie in der Schule unter dem Begriff Mengenlehre lernten, wenden CAD-Programme in der Praxis an.

Schnittmenge

Die Schnittmenge kann aus Körpern erzeugt werden, die sich teilweise oder komplett überlagern.

Sub Beispiel_Schnittmenge()

Dim objQuader As Acad3DSolid

Dim dblQuZentrum(0 To 2) As Double

Dim dblQuHoehe As Double

Dim dblQuBreite As Double

Dim dblQuLaenge

dblQuZentrum(0) = 20: dblQuZentrum(1) = 20: dblQuZentrum(2) = 0

dblQuLaenge = 50: dblQuBreite = 50: dblQuHoehe = 50

' Quader erzeugen

Set objQuader = ThisDrawing.ModelSpace.AddBox(dblQuZentrum, dblQuLaenge, dblQuBreite, dblQuHoehe)

'Zylinder zeichnen

Dim objZylinder As Acad3DSolid

Dim dblZZentrum(0 To 2) As Double

Dim dblZRadius As Double

Dim dblZHoehe As Double

dblZZentrum(0) = 50: cylinderCenter(1) = 50: cylinderCenter(2) = 0

dblZRadius = 25

dblZHoehe = 100

Set objZylinderObj = ThisDrawing.ModelSpace.AddCylinder(cylinderCenter, cylinderRadius, cylinderHeight)

' Ansichtspunkt

Dim NewDirection(0 To 2) As Double

NewDirection(0) = -1: NewDirection(1) = -1: NewDirection(2) = 1

ThisDrawing.ActiveViewport.Direction = NewDirection

ThisDrawing.ActiveViewport = ThisDrawing.ActiveViewport

ZoomAll

MsgBox "Die Schnittmenge von 2 Körpern", vbOKOnly

objQuader.Boolean acIntersection, cylinderObj

ThisDrawing.Regen True

MsgBox "Fertig"

End Sub

Differenz

Bohrungen in einem Volumenkörper werden erzeugt, indem man in das Volumen eines Grundkörpers einen Zylinder zeichnet und den Zylinder mit der Methode Differenz vom Grundkörper abzieht.

Vereinigung

Mit der Methode Vereinigung kann aus vielen Einzelkörpern ein Gesamtkörper entstehen. Achten Sie darauf, dass Körper, die ein gemeinsames Volumen belegen und nicht mit Vereinigung zu einem Teil gemacht wurden, bei der Volumenberechnung ein falsches Ergebnis liefern.

Masseneigenschaften

Mit den Masseeigenschaften können Sie Volumen, Trägheits-, Deviationsmomente u.a. berechnen lassen. Über VBA können Sie auch eine Dichte zuweisen und die Masse berechnen. In AutoCAD gibt es diese Option nicht. Dort wird die Masse mit der Dichte 1 und entspricht damit dem Volumen.

Volumenberechnung

Das folgende Beispiel ruft die Funktion ZeichnenQuader auf, die den Datentyp Acad3DSolid zurückgibt. Der Rückgabewert wird durch 1.000.000 geteilt, um die mm³ in dm³ umzurechnen.

Vom Rückgabewert wird die Eigenschaft Volumen abgefragt.

Sub Beispiel_Volumen()

Dim dblVolumen As Double

dblVolumen = ZeichnenQuader.Volume / 1000000

AnsichtIso 'Funktion AnsichtIso aufrufen

ZoomAll

MsgBox "Das Volumen beträgt " & dblVolumen & " Kubikdezimeter." & vbCr _

& "Bei einer Dichte von 8 Kg/dm³ eine Masse von " & dblVolumen * 8 & " kg"

End Sub

Funktion QuaderZeichnen erstellt einen Quader:

Function ZeichnenQuader() As Acad3DSolid

Dim dblLaenge As Double, dblBreite As Double, dblHoehe As Double

Dim dblZentrum(0 To 2) As Double

dblZentrum(0) = 50: dblZentrum(1) = 50: dblZentrum(2) = 0

dblLaenge = 50: dblBreite = 70: dblHoehe = 100

Set ZeichnenQuader = ThisDrawing.ModelSpace.AddBox(dblZentrum, dblLaenge, dblBreite, dblHoehe)

End Function

Funktion AnsichtIso schaltet auf Iso Südwest um:

Function AnsichtIso()

Dim dblRichtung(0 To 2) As Double

dblRichtung(0) = -1: dblRichtung(1) = -1: dblRichtung(2) = 1

ThisDrawing.ActiveViewport.Direction = dblRichtung

ThisDrawing.ActiveViewport = ThisDrawing.ActiveViewport

End Function

Die folgende Prozedur berechnet das Flächenträgheitsmoment:

Public Sub Beispiel_Traegheit()

Dim TrMoment As Variant

AnsichtIso 'Ansicht Isometrie, siehe oben

TrMoment = ZeichnenQuader.momentOfInertia 'ZeichenQuader siehe oben

MsgBox "Das Trägheitsmoment ist " & TrMoment(0) & ", " & TrMoment(1) & ", " & TrMoment(2)

End Sub

Die folgende Prozedur zeigt die Hauptrichtungen des Quaders an.

Sub Beispiel_Hauprichtungen()

Dim varHauptrichtung As Variant

varHauptrichtung = ZeichnenQuader.PrincipalDirections

AnsichtIso

ZoomAll

MsgBox "Die Hauptrichtungen sind " & varHauptrichtung(0) & ", " & varHauptrichtung(1) & ", " & varHauptrichtung(2)

End Sub

Nachfolgend sehen Sie die Berechnung der Hauptmomente des Quaders:

Sub Beispie_Hauptmomente()

Dim varHauptMomente As Variant

varHauptMomente = ZeichnenQuader.PrincipalMoments

AnsichtIso

ZoomAll

MsgBox "Die Hauptmomente sind I: " & varHauptMomente(0) & ", J: " & varHauptMomente(1) & ", K: " & varHauptMomente(2)

End Sub

Deviation:

Sub Beispiel_Produkt()

Dim varProdukt As Variant

varProdukt = ZeichnenQuader.ProductOfInertia

MsgBox "Deviation XY " & varProdukt(0) & ", YZ " & varProdukt(1) & ", ZX " & varProdukt(2)

End Sub

Trägheitsradien

Sub Beispiel_Radien()

Dim varRadien As Variant

varRadien = ZeichnenQuader.RadiiOfGyration

MsgBox "The RadiiOfGyration for the box is " & varRadien(0) & ", " & varRadien(1) & ", " & varRadien(2)

End Sub

Schwerpunkt:

Sub MassenSchwerPunkt()

Dim varSchwerPunkt As Variant

varSchwerPunkt = ZeichnenQuader.Centroid

MsgBox "Der Schwerpunkt liegt in " & varSchwerPunkt(0) & ", " & varSchwerPunkt(1)

End Sub

Beschriftung

· Wie erzeugt man Textstile

· Wie wird eine Schriftart zugewiesen

· Wie legt man die Textposition fest

· Wie erstellt man eine Führung

Beschriftung

Die Beschriftung muss speziell beim Ausdrucken von verschiedenen Maßstäben angepaßt werden. Hier bietet es sich an, dass man eine Routine schreibt, welche automatisch die Textgröße an den Zoomfaktor anpaßt. So ist gewährleistet, dass unabhängig vom Maßstab die Textgröße immer auf z.B. 5 mm eingestellt ist.

Textstile

Bevor in AutoCAD ein Textstil verwendet werden kann, muss er erzeugt werden. Der Textstil erhält einen Namen und eine Windows- oder AutoCAD-Schriftart.

Die TrueType-Schriftarten (Symbol TT) von Windows sehen schön aus, benötigen aber wegen der Darstellung mehr Speicher als die AutoCAD-Schriftarten (Zirkel-Symbol).

Erzeugen und setzen eines Textstils

Sub Beispiel_TextStil()

Dim objNeuStil As AcadTextStyle

Dim objAltStil As AcadTextStyle

Set objAltStil = ThisDrawing.ActiveTextStyle

MsgBox "Der aktuelle Textstil ist " & objAltStil.Name, vbInformation

'Neuen Textsil erzeugen und setzen

Set objNeuStil = ThisDrawing.TextStyles.Add("VBATextStil")

ThisDrawing.ActiveTextStyle = objNeuStil

MsgBox "Der aktuelle Textstil ist " & objNeuStil.Name, vbInformation

'vorherigen Stil setzen

ThisDrawing.ActiveTextStyle = objAltStil

MsgBox "Der aktuelle Textstil ist wieder " & objAltStil.Name, vbInformation

End Sub

Schriftart zuweisen

Sub SchriftArtSetzen()

Dim objTxtStil1 As AcadTextStyle

Dim strAktTxtStil As String

Dim strNeuFont As String

Set objTxtStil1 = ThisDrawing.ActiveTextStyle

strAktTxtStil = objTxtStil1.fontFile

MsgBox "Akteller Font " & strAktTxtStil, vbInformation, "Schriftart"

'andere Schriftart setzen

strNeuFont = "c:/programme/Acad2000/Fonts/italic.shx"

objTxtStil1.fontFile = strNeuFont

MsgBox "Die neue Schriftart ist " & objTxtStil1.fontFile, vbInformation, "Schriftart"

'zurücksetzen

objTxtStil1.fontFile = strAktTxtStil

MsgBox "Die Schriftart wurde von " & strAktTxtStil & " auf " & objTxtStil1.fontFile & " zurückgesetzt", vbInformation, "Schriftart"

End Sub

Textposition

Sie können einzeiligen Text mit Hilfe einer der in der folgenden Abbildung gezeigten Optionen horizontal und vertikal ausrichten. Die Vorgabeeinstellung ist linksbündig. Verwenden Sie die Alignment-Eigenschaft, um die Optionen für horizontale und vertikale Ausrichtung festzulegen.

Im folgenden Beispiel wird ein Text- und ein Point-Objekt erzeugt. Das Point-Objekt wird auf den Textausrichtungspunkt gesetzt und in ein rotes Fadenkreuz geändert, so dass es sichtbar ist. Die Textausrichtung wird geändert und ein Meldungsfeld wird angezeigt, so dass die Makroausführung gestoppt wird. Dadurch ist es Ihnen möglich, das Ergebnis der an der Textausrichtung vorgenommenen Änderung zu sehen.

Sub Ch4_TextAlignment()

Dim textObj As AcadText

Dim textString As String

Dim insertionPoint(0 To 2) As Double

Dim height As Double

' Define the new Text object

textString = "Hello, World."

insertionPoint(0) = 3

insertionPoint(1) = 3

insertionPoint(2) = 0

height = 0.5

' Create the Text object in model space

Set textObj = ThisDrawing.ModelSpace. _

AddText(textString, insertionPoint, height)

' Create a point over the text alignment point,

' so we can better visualize the alignment process

Dim pointObj As AcadPoint

Dim alignmentPoint(0 To 2) As Double

alignmentPoint(0) = 3

alignmentPoint(1) = 3

alignmentPoint(2) = 0

Set pointObj = ThisDrawing.ModelSpace. _

AddPoint(alignmentPoint)

pointObj.Color = acRed

' Set the point style to crosshair

ThisDrawing.SetVariable "PDMODE", 2

' Align the text to the Left

textObj.Alignment = acAlignmentLeft

ThisDrawing.Regen acActiveViewport

MsgBox "The Text object is now aligned left"

' Align the text to the Center

textObj.Alignment = acAlignmentCenter

' Align the text to the point (necessary for

' all but left aligned text.)

textObj.TextAlignmentPoint = alignmentPoint

ThisDrawing.Regen acActiveViewport

MsgBox "The Text object is now centered"

' Align the text to the Right

textObj.Alignment = acAlignmentRight

ThisDrawing.Regen acActiveViewport

MsgBox "The Text object is now aligned right"

End Sub

Führungen

Der Maßtext einer Führung kann ein Tolerance-, Mtext- oder ein BlockRef-Objekt sein. Sie können einen neuen Maßtext erstellen oder eine Kopie von einem bereits vorhandenen Maßtext hinzufügen. Maßtext wird nur zur Führung hinzugefügt, während diese erstellt wird.

Sub FührungMitBeschriftung()

Dim objFrg As AcadLeader

Dim dblPunkte(0 To 8) As Double

Dim intTyp As Integer

Dim objBeschriftung As AcadObject

Dim objMText As AcadMText, strText As String

Dim dblPunkt(0 To 2) As Double

Dim dblBreite As Double

dblPunkte(0) = 50: dblPunkte(1) = 50: dblPunkte(2) = 0

dblPunkte(3) = 60: dblPunkte(4) = 60: dblPunkte(5) = 0

' dblPunkte(6) = 80: dblPunkte(7) = 60: dblPunkte(8) = 0

intTyp = acLineWithArrow

strText = "geschliffen und geläppt"

dblPunkt(0) = 70: dblPunkt(1) = 70: dblPunkt(2) = 0

dblBreite = 20

Set objMText = ThisDrawing.ModelSpace.AddMText(dblPunkt, dblBreite, strText)

Set objBeschriftung = objMText

'Führung erzeugen

Set objFrg = ThisDrawing.ModelSpace.AddLeader(dblPunkte, objBeschriftung, intTyp)

ZoomAll

End Sub

Bemaßungen

· Wie erzeugt man einen Bemaßungsstil

· Wie werden Bemaßungsvariablen verändert

· Ausgerichtete Bemaßung u.a.

· Wie erstellt man eine automatische Radius- bzw. Durchmesserbemaßung

Bemaßungsstil

Der Bemaßungsstil steuert das Erscheinungsbild der verschiedenen Bemaßungsarten. Sie können z.B. Texthöhe, Pfeilspitzen und die Farben der einzelnen Objekte unabhängig steuern. So kann bei einer Architekturbemaßung z.B. der lineare Pfeil schräg eingestellt werden, der Pfeil der Radialbemaßung dagegen geschlossen und gefüllt.

Sie können damit sehr schnell das Erscheinungsbild der Bemaßung ändern, indem Sie die Bemaßungen markieren und einen anderen Stil zuweisen.

Bemaßungsstile können z.B. über das AutoCad Designcenter in andere Zeichnungen importiert werden.

Bemaßungsstil erzeugen

Zum Erzeugen eines Bemaßungsstils verwendet man die Add-Methode.

Function BemStilNeu()

Dim BemStil As AcadDimStyle

Set BemStil = Thisdrawing.DimStyles.Add("NeuerBemStil")

End Function

Bemaßungsstil einstellen

Setzen Sie zuerst die Bemaßungsvariablen über die SetVariable-Anweisung und wenden Sie dann die CopyFrom-Methode an.

Bemaßungsvariablen

Die Bemaßungsvariablen können in AutoCAD mit folgender Anweisung aufgelistet werden:

Befehl: setvar ¿

Variablenname eingeben oder [?]: ? ¿

Aufzulistende Variable(n) eingeben <*>: dim* ¿

Nachfolgende Tabelle zeigt die Einstellungen der verschiedenen Normen.

Bemaßungsstil nach DIN

Das folgende Beispiel erstellt einen neuen Bemaßungsstil und stellt die Variablen nach DIN-Norm (406) ein. Der Abstand der Bemaßungslinien wurde von 3.75 auf 7 vergrößert. Dieser wirkt sich bei der versetzten Bemaßung (Schnellbemaßung) bzw. bei der Basislinienbemaßung aus.

Function BemStilDin()

Dim BemStil As AcadDimStyle

With Thisdrawing

Set BemStil = .DimStyles.Add("Din_025")

.SetVariable "Dimtxt", 2.5

.SetVariable "Dimtxt", 2.5

.SetVariable "DimScale", 5

.SetVariable "DIMADEC", 0

.SetVariable "DIMALT", 0

.SetVariable "DIMALTD", 2

.SetVariable "DIMALTF", 0.394

.SetVariable "DIMALTRND", 0

.SetVariable "DIMALTTD", 2

.SetVariable "DIMALTTZ", 0

.SetVariable "DIMALTU", 8

.SetVariable "DIMALTZ", 0

.SetVariable "DIMASZ", 2.5

.SetVariable "DIMATFIT", 3

.SetVariable "DIMAUNIT", 0

.SetVariable "DIMAZIN", 0

.SetVariable "DIMCEN", 2.5

.SetVariable "DIMCLRD", 0

.SetVariable "DIMCLRE", 0 'vonBlock

.SetVariable "DIMCLRT", 0

.SetVariable "DIMDEC", 4

.SetVariable "DIMDLE", 0

.SetVariable "DIMDLI", 7 '3.75 nach Norm

.SetVariable "DIMEXE", 1.25

.SetVariable "DIMEXO", 0.625

.SetVariable "DIMFRAC", 0

.SetVariable "DIMGAP", 0.625

.SetVariable "DIMJUST", 0

.SetVariable "DIMLFAC", 1

.SetVariable "DIMLIM", 0

.SetVariable "DIMLUNIT", 6

.SetVariable "DIMLWD", -2

.SetVariable "DIMLWE", -2

.SetVariable "DIMRND", 0

.SetVariable "DIMSAH", 0

.SetVariable "DIMSCALE", 1

.SetVariable "DIMSD1", 0

.SetVariable "DIMSD2", 0

.SetVariable "DIMSE1", 0

.SetVariable "DIMSE2", 0

.SetVariable "DIMSOXD", 0

.SetVariable "DIMTAD", 1

.SetVariable "DIMTDEC", 4

.SetVariable "DIMTFAC", 1

.SetVariable "DIMTIH", 0

.SetVariable "DIMTIX", 0

.SetVariable "DIMTM", 0

.SetVariable "DIMTMOVE", 0

.SetVariable "DIMTOFL", 1

.SetVariable "DIMTOH", 0

.SetVariable "DIMTOL", 0

.SetVariable "DIMTOLJ", 1

.SetVariable "DIMTP", 0

.SetVariable "DIMTSZ", 0

.SetVariable "DIMTVP", 0

.SetVariable "DIMTXSTY", "STANDARD"

.SetVariable "DIMTXT", 2.5

.SetVariable "DIMTZIN", 0

.SetVariable "DIMUPT", 0

.SetVariable "DIMZIN", 8

End With

Call BemStil.CopyFrom(Thisdrawing)

End Function

Ausgerichtete Bemaßung

Sub AusgerichteteBemassung()

Dim objBem As AcadDimAligned

Dim dblPunkt1(0 To 2) As Double

Dim dblPunkt2(0 To 2) As Double

Dim dblPos(0 To 2) As Double

' Bemaßungspunkte

dblPunkt1(0) = 50: dblPunkt1(1) = 50: dblPunkt1(2) = 0

dblPunkt2(0) = 100: dblPunkt2(1) = 50: dblPunkt2(2) = 0

dblPos(0) = 50: dblPos(1) = 60: dblPos(2) = 0

'ausgerichtete Bemaßung im Modellbereich

Set objBem = ThisDrawing.ModelSpace.AddDimAligned(dblPunkt1, dblPunkt2, dblPos)

ZoomAll

End Sub

Durchmesserbemaßung

Sub ErstellenDurchmesserBem()

Dim objBem As AcadDimDiametric

Dim dblKoord1(0 To 2) As Double

Dim dblKoord2(0 To 2) As Double

Dim dblFrgLaenge As Double

dblKoord1(0) = 70: dblKoord1(1) = 70: dblKoord1(2) = 0

dblKoord2(0) = 50: dblKoord2(1) = 70: dblKoord2(2) = 0

dblFrgLaenge = 10

Set objBem = Thisdrawing.ModelSpace.AddDimDiametric(dblKoord1, dblKoord2, dblFrgLaenge)

ZoomExtents

End Sub

Automatische Durchmesserbemaßung

Function AlleKreiseDurchmesserBem()

Dim objEnt As AcadEntity

Dim objBem As AcadDimDiametric

Dim objKreis As AcadCircle

Dim dblKoord1(0 To 2) As Double

Dim dblKoord2(0 To 2) As Double

Dim intFrgLaenge As Integer

For Each objEnt In Thisdrawing.ModelSpace

intFrgLaenge = 10

If objEnt.ObjectName = "AcDbCircle" Then

Set objKreis = objEnt

dblKoord1(0) = objKreis.center(0) - objKreis.radius

dblKoord1(1) = objKreis.center(1)

dblKoord1(2) = objKreis.center(2)

dblKoord2(0) = objKreis.center(0) + objKreis.radius

dblKoord2(1) = objKreis.center(1)

dblKoord2(2) = objKreis.center(2)

Call AutoDurchmesserBem(dblKoord1, dblKoord2, intFrgLaenge)

End If

Next

End Function

Winkelbemaßung mit 3 Punkten

Sub DreiPunktWinkelbemassung()

Dim objBem As AcadDim3PointAngular

Dim dblScheitel(0 To 2) As Double

Dim dblEnd1(0 To 2) As Double, dblEnd2(0 To 2) As Double

Dim dblTxtPos(0 To 2) As Double

'Punkte für die Bemaßung festlegen

dblScheitel(0) = 100: dblScheitel(1) = 100: dblScheitel(2) = 0

dblEnd1(0) = 101: dblEnd1(1) = 101: dblEnd1(2) = 0

dblEnd2(0) = 101: dblEnd2(1) = 100: dblEnd2(2) = 0

dblTxtPos(0) = 110: dblTxtPos(1) = 110: dblTxtPos(2) = 0

' Erzeugt die Bemaßung im Modellbereich

Set objBem = ThisDrawing.ModelSpace.AddDim3PointAngular(dblScheitel, dblEnd1, dblEnd2, dblTxtPos)

ThisDrawing.Application.ZoomExtents

End Sub

Radialbemaßung

Radialbemaßungen enthalten die Maßangaben für Radien und Durchmesser von Bogen und Kreisen. Verwenden Sie die Methode AddDimRadial zum Erstellen einer Radialbemaßung.

In Abhängigkeit von der Größe des Kreises oder Bogens, der TextPosition-Eigenschaft und den Werten der Systemvariablen DIMUPT, DIMTOFL, DIMFIT, DIMTIH, DIMTOH, DIMJUST und DIMTAD können verschiedene Radialbemaßungstypen erstellt werden. (Systemvariablen können mit den Methoden GetVariable and SetVariable abgefragt und eingestellt werden.)

AutoCAD zeichnet bei horizontalem Maßtext eine Ansatzlinie, wenn die Maßlinie mehr als 15 Grad von der horizontalen abweicht und sich außerhalb des Kreises oder Bogens befindet. Die Ansatzlinie hat die Länge einer Pfeilspitze und befindet sich neben dem Maßtext, wie in den ersten beiden Abbildungen dargestellt:

Verwenden Sie die Methoden AddDimRadial oder AddDimDiametric zum Erstellen von Radialbemaßungen. Diese Methoden erfordern die Eingabe von drei Werten: die Koordinate für den Mittelpunkt des Kreises bzw. Bogens, die Koordinate der Führungsverknüpfung und die Führungslänge.

Bei diesen Methoden gibt der Parameter Führungslänge die Entfernung vom Sehnenpunkt zu dem Punkt an, an dem die Bemaßung mit einer horizontalen Ansatzlinie zum Maßtext versehen ist (oder endet, falls keine Ansatzlinie erforderlich ist).

Sub ErstellenRadialBem()

Dim objBem As AcadDimRadial

Dim dblZentrum(0 To 2) As Double

Dim dblKoordinate(0 To 2) As Double

Dim intFrgLaenge As Integer

'Bemaßung definieren

dblZentrum(0) = 50

dblZentrum(1) = 50

dblZentrum(2) = 0

dblKoordinate(0) = 70

dblKoordinate(1) = 50

dblKoordinate(2) = 0

intFrgLaenge = 25

' Bemaßung im Modellbereich

Set objBem = Thisdrawing.ModelSpace. _

AddDimRadial(dblZentrum, dblKoordinate, intFrgLaenge)

ZoomExtents

End Sub

Automatische Radiusbemaßung aller Kreise

Die folgende Routine ermittelt alle Kreise im Modellbereich und fügt jeweils eine Radiusbemaßung im Winkel von 45° und im Abstand von 10 Einheiten hinzu. Die Berechnung des Punktes erfolgt über die Funktionen Sin(Winkel) und Cos(Winkel).

Function AutoKreisBem()

Dim objEnt As AcadEntity

Dim objKreis As AcadCircle

Dim dblZentrum(0 To 2) As Double

Dim dblKoordinate(0 To 2) As Double

Dim dblRadius As Double

Dim intLaenge As Integer

For Each objEnt In Thisdrawing.ModelSpace

intLaenge = 10

If objEnt.ObjectName = "AcDbCircle" Then

Set objKreis = objEnt

dblZentrum(0) = objKreis.center(0)

dblZentrum(1) = objKreis.center(1)

dblZentrum(2) = objKreis.center(2)

dblRadius = objKreis.radius

dblKoordinate(0) = dblZentrum(0) + dblRadius * Cos(45)

dblKoordinate(1) = dblZentrum(1) + dblRadius * Sin(45)

dblKoordinate(2) = dblZentrum(2)

Call RadialBem(dblZentrum, dblKoordinate, intLaenge)

End If

Next

End Function

Sub RadialBem(dblZentrum, dblKoordinate, intLaenge)

Dim objBem As AcadDimRadial

Set objBem = Thisdrawing.ModelSpace. _

AddDimRadial(dblZentrum, dblKoordinate, intLaenge)

End Sub

Winkelbemaßung

Bei Winkelbemaßungen wird der Winkel zwischen zwei Linien bzw. drei Punkten gemessen. Sie können zum Beispiel den Winkel zwischen zwei Radien eines Kreises messen. Die Maßlinie bildet einen Bogen.

Verwenden Sie zum Erstellen einer Winkelbemaßung die Methode AddDimAngular. Diese Methode erfordert die Eingabe von drei Werten: den Scheitelpunkt des Winkels, die Ursprungspunkte der Hilfslinien und die Textposition. Der Winkelscheitelpunkt ist der Mittelpunkt des Kreises bzw. Bogens oder der gemeinsame Scheitelpunkt der beiden bemaßten Linien. Die Ursprungspunkte der Hilfslinien sind die Punkte, durch die die beiden Hilfslinien verlaufen.

Der Winkelscheitelpunkt kann mit einem der Ursprungspunkte identisch sein. Falls erforderlich, werden Hilfslinien automatisch ergänzt.

In diesem Beispiel wird eine Winkelbemaßung im Modellbereich erstellt.

Sub ErstellenWinkelBem()

Dim objBem As AcadDimAngular

Dim dblZentrum(0 To 2) As Double

Dim dblKoordinate(0 To 2) As Double

Dim intFrgLaenge As Integer

Dim dblScheitel(0 To 2) As Double

Dim dblErsterP(0 To 2) As Double

Dim dblZweiterP(0 To 2) As Double

Dim dblTextPos(0 To 2) As Double

dblScheitel(0) = 50

dblScheitel(1) = 50

dblScheitel(2) = 0

dblErsterP(0) = 55

dblErsterP(1) = 50

dblErsterP(2) = 0

dblZweiterP(0) = 50

dblZweiterP(1) = 55

dblZweiterP(2) = 0

dblTextPos(0) = 55

dblTextPos(1) = 55

dblTextPos(2) = 0

'Bemaßung im Modellbereich

Set objBem = Thisdrawing.ModelSpace. _

AddDimAngular(dblScheitel, dblErsterP, dblZweiterP, dblTextPos)

ZoomExtents

End Sub

Koordinatenbemaßung

Mit Hilfe von Koordinatenbemaßungen wird der lotrechte Abstand von einem Ursprungspunkt, des Bezugspunkts, zu einem bemaßten Element der Zeichnung gemessen, wie zum Beispiel einer Aussparung in einem Bauteil.

Koordinatenbemaßungen bestehen aus einer X- oder Y-Koordinate mit einer Führungslinie. Koordinatenbemaßungen mit einem X-Wert messen den Abstand eines Zeichnungselements zum Bezugspunkt auf der X-Achse. Koordinatenbemaßungen mit einem Y-Wert messen denselben Abstand auf der Y-Achse. AutoCAD bestimmt die gemessenen Koordinaten und verwendet dabei den Ursprung des aktuellen BKS. Dabei wird der absolute Wert der Koordinate verwendet.

Der Text wird an der Koordinatenführungslinie ohne Berücksichtigung der durch den aktuellen Bemaßungsstil vorgegebenen Textausrichtung ausgerichtet. Sie können entweder den Vorgabetext übernehmen oder Ihren eigenen Text verwenden.

Verwenden Sie zum Erstellen einer Koordinatenbemaßung die Methode AddDimOrdinate. Diese Methode erfordert die Eingabe von drei Werten: einer Koordinate, die den zu bemaßenden Punkt benennt (A), einer Koordinate, die das Ende der Führung benennt (B), und eine Boolesche Markierung, die angibt, ob die Bemaßung eine Koordinatenbemaßung des X-Werts oder des Y-Werts ist. Wenn Sie als Boolesche Markierung TRUE eingeben, wird eine Koordinatenbemaßung des X-Bezugspunkts erstellt. Wenn Sie FALSE eingeben, wird eine Koordinatenbemaßung des Y-Bezugspunkts erstellt.

Koordinatenbemaßung Erstellen

In diesem Beispiel wird eine Koordinatenbemaßung im Modellbereich erstellt.

Sub ErstellenKoordBem()

Dim objBem As AcadDimOrdinate

Dim dblDefPunkt(0 To 2) As Double

Dim dblFrgEnde(0 To 2) As Double

Dim lngXAchse As Long

dblDefPunkt(0) = 50

dblDefPunkt(1) = 30

dblDefPunkt(2) = 0

dblFrgEnde(0) = 50

dblFrgEnde(1) = 60

dblFrgEnde(2) = 0

lngXAchse = 50

' Bemaßung im Modellbereich erzeugen

Set objBem = Thisdrawing.ModelSpace. _

AddDimOrdinate(dblDefPunkt, dblFrgEnde, lngXAchse)

ZoomExtents

End Sub

Toleranzen

Geometrische Toleranzen zeigen zulässige Abweichungen von Form, Profil, Ausrichtung, Position und Lauf eines Elements. Geometrische Toleranzen werden in Form- und Lagetoleranzen eingefügt. Diese enthalten alle Toleranzinformationen für eine einzelne Bemaßung.

Verwenden Sie die AddTolerance-Methode zum Erstellen einer geometrischen Toleranz. Diese Methode erfordert die Eingabe von drei Werten: der Zeichenfolge, aus der das Toleranzsymbol besteht, der vorgesehenen Position für die Toleranz in der Zeichnung und eines Richtungsvektors, der die Richtung der Toleranz angibt.

Sie können Toleranzen ebenfalls kopieren, verschieben, löschen, skalieren und drehen.

Form- und Lagetoleranzen bestehen aus mindestens zwei Teilen. Der erste Teil enthält ein Symbol für die geometrische Eigenschaft, das die Eigenschaft darstellt, auf die eine Toleranz angewendet wird, zum Beispiel Form, Ausrichtung oder Lauf. Formtoleranzen steuern Geradlinigkeit, Ebenheit, Kreisförmigkeit, Zylinderform sowie die Profile von Linie und Oberfläche.

Der zweite Teil der Form- und Lagetoleranzen enthält den Toleranzwert. In manchen Fällen steht vor dem Toleranzwert das Durchmessersymbol und danach ein Symbol für die Materialbedingung.

Geometrischen Toleranz erstellen

In diesem Beispiel wird eine einfache geometrische Toleranz im Modellbereich erstellt.

Sub ErstellenToleranz()

Dim objTol As AcadTolerance

Dim strText As String

Dim dblEinPunkt(0 To 2) As Double

Dim dblRichtung(0 To 2) As Double

strText = "A 0.1"

dblEinPunkt(0) = 50

dblEinPunkt(1) = 50

dblEinPunkt(2) = 0

dblRichtung(0) = 1

dblRichtung(1) = 1

dblRichtung(2) = 0

' Toleranz im Modellbereich

Set objTol = Thisdrawing.ModelSpace. _

AddTolerance(strText, dblEinPunkt, dblRichtung)

ZoomExtents

End Sub

Toleranzen: Systemvariablen

· DIMCLRD Bestimmt die Farbe der Form- und Lagetoleranzen

· DIMCLRT Farbe des Toleranztextes

· DIMGAP Abstand zwischen den Form- und Lagetoleranzen und dem Text

· DIMTXT Größe des Toleranztextes

· DIMTXTSTY Stil des Toleranztextes.

Stellen Sie die Werte von Systemvariablen mit Hilfe der SetVariable-Methode ein.

Auswahlsätze: Ergänzung

· Auswahlsätze erzeugen und darauf zugreifen

· Objekte aus Auswahlsätzen entfernen bzw. hinzufügen

· Filtersätze mit DXF-Codes erzeugen

Der SelectionSet (Auswahlsatz) wird in AutoCAD nur kurzzeitig gespeichert. Z.B. ist der Objektwahlbefehl "v" für vorherigen Auswahlsatz verfügbar, wenn kurz vorher Objekte gewählt wurden und zwischenzeitlich nicht der Befehl "Zurück" ausgeführt wurde. Der Auswahlsatz "L" für letztes Objekt ist nach dem Erstellen eines Objekts verfügbar.

Die Auswahl bestimmter Objekte kann in Auswahlsätzen gespeichert werden. Bei Bedarf kann ein benannter Auswahlsatz später wieder abgerufen werden.

Auswahlauflistung durchlaufen

Im Beispiel werden alle in der Zeichnung vorhandenen Auswahlsätze durchlaufen und die Namen in einer MsgBox ausgegeben.

Sub AuswahlDurchlaufen()

Dim objSset As AcadSelectionSet

For Each objSset In ThisDrawing.SelectionSets

MsgBox objSset.Name

Next

End Sub

Zugriff auf Auswahlsätze

Um auf bestehende Auswahlsätze zuzugreifen, bietet sich die Item-Methode an.

Sub ObjekteImAuswahlSatz()

Dim objSset As AcadSelectionSet

Dim objEnt As AcadEntity

Set objSset = ThisDrawing.SelectionSets.Item("NeuerAuswahlsatz")

For Each objEnt In objSset

MsgBox objEnt.ObjectName

Next

End Sub

Methoden der Auswahlsätze

Hinzufügen zu einem Auswahlsatz

Sub AuswahlSatzErzeugen()

Dim objSset As AcadSelectionSet

Dim objEnt As AcadEntity

'Auswahlauflistung durchlaufen und den Auswahlsatz "NeuerAuswahlsatz" entfernen, 'falls er existiert

For Each objSset In ThisDrawing.SelectionSets

If objSset.Name = "NeuerAuswahlsatz" Then

objSset.Delete

End If

Next

Set objSset = ThisDrawing.SelectionSets.Add("NeuerAuswahlsatz")

objSset.SelectOnScreen

'Allen Objekten im Auswahlsatz den Layer 0 zuweisen

For Each objEnt In objSset

objEnt.Layer = "0"

Next objEnt

End Sub

Entfernen aus dem Auswahlsatz

Nach der Erstellung eines Auswahlsatzes können Sie einzelne Objekte oder alle Objekte aus diesem Satz entfernen. Sie können beispielsweise eine ganze Gruppe dicht gruppierter Objekte auswählen und dann bestimmte Objekte aus dieser Gruppe entfernen, so dass sich nur noch die gewünschten Objekte im Auswahlsatz befinden.

RemoveItems

Die RemoveItems-Methode entfernt eines oder mehrere Elemente aus einem Auswahlsatz. Die entfernten Elemente sind weiterhin vorhanden, aber nicht mehr innerhalb des Auswahlsatzes.

objSset.RemoveItems

Clear

Die Clear-Methode leert den Auswahlsatz. Der Auswahlsatz ist weiterhin vorhanden, enthält aber keine Elemente mehr. Die vorher im Auswahlsatz befindlichen Elemente sind weiterhin vorhanden, aber nicht mehr innerhalb des Auswahlsatzes.

objSset.Clear

Erase

Die Erase-Methode löscht alle Elemente in einem Auswahlsatz. Der Auswahlsatz ist danach noch vorhanden, enthält aber keine Elemente mehr. Die vorher im Auswahlsatz befindlichen Elemente sind danach nicht mehr vorhanden.

objSset.Erase

Delete

Die Delete-Methode löscht einen Auswahlsatz mit allen Elementen. Sowohl der Auswahlsatz als auch die vorher darin befindlichen Elemente sind danach nicht mehr vorhanden.

objSset.Delete

Sub AusAuswahlEntfernen()

Dim objSset As AcadSelectionSet

Dim objEnt As AcadEntity

On Error Resume Next

'Auswahlsatz löschen, falls vorhanden

For Each objSset In Thisdrawing.SelectionSets

If objSset.Name = "NeuerAuswahlsatz" Then

objSset.Delete

End If

Next

Set objSset = Thisdrawing.SelectionSets.Add("NeuerAuswahlsatz")

objSset.SelectOnScreen

'Alle Kreise aus Auswahl entfernen

For Each objEnt In objSset

If objEnt.ObjectName = "AcDbCircle" Then

objSset.RemoveItems objEnt

End If

Next objEnt

End Sub

Filtersätze

Sie können Auswahlsätze durch die Angabe von Eigenschaften wie Farbe oder Objekttyp eingrenzen, indem Sie Filterlisten verwenden. So können Sie zum Beispiel nur die roten Objekte aus einer Leiterplattenzeichnung oder nur die Objekte eines bestimmten Layers kopieren.

ANMERKUNG Beim Filtern werden nur die Farben und Linientypen erkannt, die Objekten ausdrücklich zugewiesen worden sind, jedoch nicht diejenigen, die über den Layer vererbt worden sind.

Um den Filtermechanismus zu verwenden, geben Sie den Filtertyp und die Filterdaten an, nach denen sortiert wird. Der Filtertyp ist ein Code, durch den der zu verwendende Filter angegeben wird. Die AutoCAD ActiveX-Automatisierung verwendet zur Angabe der Filtertypen die DXF-Gruppencodes. Im folgenden finden Sie eine Auflistung einiger der am häufigsten verwendeten Filtertypen. Eine vollständige Liste finden Sie in der AutoCAD DXF-Referenz.

Filter: DXF-Codes für häufig verwendete Filter

Filter: Textobjekte

FilterType = 0

FilterData = "TEXT"

sset.SelectOnScreen FilterType, FilterData

Filter: Linienbobjekte

FilterType = 0

FilterData = "LINE"

sset.SelectOnScreen FilterType, FilterData

Filter: Layer "Kon_035"

FilterType = 8

FilterData = "Kon_035"

sset.SelectOnScreen FilterType, FilterData

Filter: Farbe rot

Filter Type = 62

Filter Data = 5

sset.SelectOnScreen FilterType, FilterData

Blöcke

· Blöcke erzeugen und ändern

· Blöcke einzeln bzw. mehrfach einfügen

· WBlöcke erzeugen

Blöcke sind häufig benötigte Zeichnungselemente, wie Schrauben, Muttern, Widerstände, Zentrierbohrungen, Bauteile oder Baugruppen u.a. Ein Block wird, obwohl er aus vielen Objekten bestehen kann als einzelnes Objekt angesprochen.

Sie können Zeit sparen, indem Sie Blöcke verwenden. Ein Block kann innerhalb einer Zeichnung gespeichert werden, aber auch nur in dieser Zeichnung verwendet werden. Wird der Block auf der Festplatte (WBlock) gespeichert, kann er beliebig in Zeichnungen eingefügt werden.

Sie reduzieren den Speicherbedarf, weil ein eingefügter Block als Referenzobjekt verwendet wird. Wird der Block mehrfach eingefügt, speichert AutoCad nur einmal den Block und erstellt jeweils eine Referenz.

Bei jedem Einfügen einer Blockreferenz können Sie dem eingefügten Block einen Skalierfaktor und einen Drehwinkel zuordnen. Darüber hinaus können Sie eine Blockreferenz auch skalieren, indem Sie für die verschiedenen Richtungen des Koordinatensystems (X, Y, Z) unterschiedliche Skalierfaktoren angeben.

Blöcke ermöglichen es Ihnen, die einzelnen Zeichenschritte systematisch zu organisieren, so dass Sie die Objekte in Ihren Zeichnungen und damit verknüpfte Informationen erstellen, überarbeiten und ordnen können.

Wird der Block in der Zeichnung geändert, ändern sich automatisch alle bestehenden Blöcke in dieser Zeichnung.

Durchlaufen der Blocksauflistung

Public Sub BloeckeAuflisten()

Dim objBlock As AcadBlock

Dim strBloecke As String

For Each objBlock In Thisdrawing.Blocks

strBloecke = strBloecke & objBlock.Name & vbCr

Next

MsgBox strBloecke

End Sub

Die Blocks-Auflistung enthält auch den Papierbereich und den Modellbereich. Die folgende Routine schließt diese Bereiche aus (Paperspace und Modelspace).

Public Sub BloeckeOhneBereich()

Dim objBlock As AcadBlock

Dim strBloecke As String

For Each objBlock In Thisdrawing.Blocks

If Not Right(objBlock.Name, 5) Like "space" Then

strBloecke = strBloecke & objBlock.Name & vbCr

End If

Next

MsgBox strBloecke

End Sub

Erzeugen von Blöcken

Verwenden Sie die Add-Methode, um einen neuen Block zu erstellen. Diese Methode erfordert zwei Werte als Eingabe, den den Einfügepunkt und den Namen des zu erstellenden Blocks.

Sub BlockErzeugen()

Dim objBlocks As AcadBlocks

Dim objNeuerBlock As AcadBlock

Dim dblEinfuegePunkt(0 To 2) As Double

Set objBlocks = Thisdrawing.Blocks

dblEinfuegePunkt(0) = 0#: dblEinfuegePunkt(1) = 0#: dblEinfuegePunkt(2) = 0#

'Block erzeugen

Set objNeuerBlock = objBlocks.Add(dblEinfuegePunkt, "NeuerBlock")

End Sub

Nachdem ein Block erstellt wurde, können Sie beliebige geometrische Objekte oder andere Blöcke in den neu erstellten Block einfügen. Anschließend können Sie ein Blockexemplar in die Zeichnung einfügen. Ein eingefügter Block ist ein Objekt und wird als Blockreferenz bezeichnet.

Sie können Blöcke auch mit Hilfe der WBlock-Methode erstellen, mit der Sie Objekte in einer gesonderten Zeichnungsdatei gruppieren. Diese Zeichnungsdatei kann dann für andere Zeichnungen als Blockdefinition verwendet werden. AutoCAD betrachtet jede Zeichnung, die Sie in eine andere Zeichnung einfügen, als Block.

Blockobjekte hinzufügen

Sub BlockObjekteHinzufuegen()

Dim objBlock As AcadBlock

Dim dblEinfuegePunkt(0 To 2) As Double

Dim objLinie(0 To 1) As AcadLine

dblEinfuegePunkt(0) = 100: dblEinfuegePunkt(1) = 100: dblEinfuegePunkt(2) = 0

Set objBlock = Thisdrawing.Blocks.Add _

(dblEinfuegePunkt, "Block_S")

Dim objKreis As AcadCircle

Dim dblZentrum(0 To 2) As Double

Dim dblRadius As Double

dblZentrum(0) = 100: dblZentrum(1) = 100: dblZentrum(2) = 0

dblRadius = 3

'Linien

Dim dblStart1(0 To 2) As Double

Dim dblEnd1(0 To 2) As Double

Dim dblStart2(0 To 2) As Double

Dim dblEnd2(0 To 2) As Double

dblStart1(0) = 100: dblStart1(1) = 95: dblStart1(2) = 0

dblEnd1(0) = 100: dblEnd1(1) = 105: dblEnd1(2) = 0

dblStart2(0) = 95: dblStart2(1) = 100: dblStart2(2) = 0

dblEnd2(0) = 105: dblEnd2(1) = 100: dblEnd2(2) = 0

' Objekte zum Block hinzufügen

Set objKreis = objBlock.AddCircle(dblZentrum, dblRadius)

Set objLinie(0) = objBlock.AddLine(dblStart1, dblEnd1)

Set objLinie(1) = objBlock.AddLine(dblStart2, dblEnd2)

End Sub

Block einfügen

Sub BlockEinfuegen()

Dim dblEinfuegePunkt(0 To 2) As Double

Dim blockRefObj As AcadBlockReference

dblEinfuegePunkt(0) = 50: dblEinfuegePunkt(1) = 50: dblEinfuegePunkt(2) = 0

Set blockRefObj = Thisdrawing.ModelSpace.InsertBlock _

(dblEinfuegePunkt, "Block_S", 1, 1, 1, 0)

End Sub

Auflösen von Blöcken

Verwenden Sie die Explode-Methode, um eine Blockreferenz aufzulösen. Durch das Auflösen einer Blockreferenz können Sie den Block bearbeiten oder weitere Elemente hinzufügen bzw. löschen. Vorsicht: Attribute gehen beim Auflösen verloren.

In diesem Beispiel wird die Funktion BockObjekteHinzufuegen aufgerufen, ein Block erzeugt und eingefügt. Danach wird dieser Bock in den Ursprung zerlegt und die Objekte in rot dargestellt.

Sub UrsprungBlock()

Dim objBlockRef As AcadBlockReference

BlockObjekteHinzufuegen

Set objBlockRef = BlockEinfuegen

' Block in den Ursprung

Dim objUrsprung As Variant

objUrsprung = objBlockRef.Explode

' Durchlaufen der Blockobjekte

Dim inti As Integer

For inti = 0 To UBound(objUrsprung)

objUrsprung(inti).Color = acRed

objUrsprung(inti).Update

MsgBox "Ursprungsobjekt " & inti & ": " _

& objUrsprung(inti).ObjectName

objUrsprung(inti).Color = acByLayer

objUrsprung(inti).Update

Next

End Sub

Einfügepunkt verändern

Wenn Sie eine Zeichnung als Block einfügen, ist der Einfügepunkt vorgabemäßig bei (0, 0, 0). Sie können den Basispunkt einer Zeichnung ändern, indem Sie die ursprüngliche Zeichnung öffnen und die SetVariable-Methode verwenden, um einen anderen Einfüge-Basispunkt für die Systemvariable INSBASE anzugeben. Wenn Sie die Zeichnung erneut einfügen, verwendet AutoCAD den neuen Basispunkt.

Papierbereichsobjekte in den Block aufnehmen

Wenn die einzufügende Zeichnung Papierbereichsobjekte enthält, werden diese Objekte nicht in die Blockdefinition der aktuellen Zeichnung aufgenommen. Um die PaperSpace-Objekte in einer anderen Zeichnung zu verwenden, öffnen Sie die ursprüngliche Zeichnungsdatei, und verwenden Sie die Add-Methode, um die Objekte als Block zu definieren. Sie können die Zeichnung im Papier- oder Modellbereich in eine andere Zeichnung einfügen.

Objekte eines Blocks

Eine Blockreferenz kann nicht durchlaufen werden, um die Objekte zu bestimmen, aus denen sie sich zusammensetzt. Sie können jedoch die ursprüngliche Blockdefinition durchlaufen oder die Blockreferenz in ihre ursprünglichen Komponenten auflösen.

Block mehrfach einfügen

Darüber hinaus können Sie ein Block-Datenfeld mit Hilfe der AddMInsertBlock-Methode einfügen. Diese Methode fügt im Gegensatz zu InsertBlock keinen einzelnen Block, sondern ein Datenfeld mit dem angegebenen Block in Ihre Zeichnung ein. Sie gibt ein MInsertBlock-Objekt zurück.

ANMERKUNG Nach dem Einfügen wird das WKS der externen Datei parallel zur XY-Ebene des aktuellen BKS der aktuellen Zeichnung ausgerichtet. Somit kann ein Block aus einer externen Datei in jeder beliebigen Ausrichtung im Raum eingefügt werden, wenn Sie vor dem Einfügen das BKS einrichten.

Public Sub BLMehrfach()

Dim dblZen(0 To 2) As Double

Dim dblEin(0 To 2) As Double

Dim sngRad As Single

Dim objKreis As AcadCircle

Dim objMBlock As AcadMInsertBlock

Dim objBlock As AcadBlock

' Koordinaten und Radius des Kreises festlegen

dblZen(0) = 50: dblZen(1) = 50: dblZen(2) = 0

dblEin(0) = 1: dblEin(1) = 1: dblEin(2) = 0

sngRad = 20

' Neuen Block erzeugen

Set objBlock = ThisDrawing.Blocks.Add(dblZen, "TestBlock")

' Kreis zum Block hinzufügen

Set objKreis = ThisDrawing.Blocks("TestBlock").AddCircle(dblZen, sngRad)

'Rechteckige Reihe festlegen, der Unterstrich erlaubt den Zeilenumbruch

Set objKreis = ThisDrawing.Blocks("TestBlock") _

.AddCircle(dblZen, sngRad)

ThisDrawing.Application.ZoomAll

MsgBox "Eine rechteckige Reihe mit dem Block " & objBlock.Name & " wurde erzeugt"

End Sub

Block neu definieren

Verwenden Sie Methoden und Eigenschaften für Block-Objekte, um einen Block neu zu definieren. Wenn ein Block neu definiert wird, werden alle Verweise auf diesen Block in der Zeichnung, d. h. alle eingefügten Blöcke, unverzüglich aktualisiert,

Konstante Attribute gehen verloren und werden durch beliebige neue, konstante Attribute ersetzt. Variable Attribute bleiben unverändert, auch wenn der neue Block keine Attribute hat.

In diesem Beispiel wird ein Block definiert und ein Kreis zur Blockdefinition hinzugefügt. Anschließend wird der Block in die Zeichnung eingefügt. Der Kreis in der Blockdefinition wird aktualisiert, so dass die Blockreferenz automatisch aktualisiert wird.

Sub BlockNeuDefinieren()

Dim objBlock As AcadBlock

Dim dblEinFuegePunkt(0 To 2) As Double

dblEinFuegePunkt(0) = 0

dblEinFuegePunkt(1) = 0

dblEinFuegePunkt(2) = 0

Set objBlock = Thisdrawing.Blocks.Add(dblEinFuegePunkt, "B2")

'Kreis hinzufügen

Dim objKreis As AcadCircle

Dim dblZentrum(0 To 2) As Double

Dim dblRadius As Double

dblZentrum(0) = 53

dblZentrum(1) = 50

dblZentrum(2) = 0

dblRadius = 100

Set objKreis = objBlock.AddCircle(dblZentrum, dblRadius)

'Block einfügen

Dim objBlockRef As AcadBlockReference

Dim test(0 To 2) As Double

dblEinFuegePunkt(0) = 20

dblEinFuegePunkt(1) = 20

dblEinFuegePunkt(2) = 0

Set objBlockRef = Thisdrawing.ModelSpace.InsertBlock(dblEinFuegePunkt, "B2", 1, 1, 1, 0)

ZoomExtents

' Block neu definieren

objKreis.radius = 5

objBlockRef.Update

End Sub

Der kleine Kreis im Zentrum wird nachträglich in den Block eingefügt.

objKreis.radius = 5

objBlockRef.Update

Übung 16 Löschen von Blöcken

Die folgende Übung zeigt, wie Blöcke gelöscht werden können.

Die folgenden Blöcke können nicht gelöscht werden:

· Modellbereich,

· Papierbereich und

· Blöcke, die in die Zeichnung eingefügt wurden

Sie würden eine Fehlermeldung verursachen.

Public Sub BloeckeLoeschen()

Dim objBlock As AcadBlock

Dim strBlName As String

Dim strGeloeschteBloecke As String

On Error GoTo BlFehler

For Each objBlock In ThisDrawing.Blocks

strBlName = objBlock.Name

objBlock.Delete

If strBlName <> "" Then

strGeloeschteBloecke = strGeloeschteBloecke & vbCr & strBlName

End If

Next

MsgBox strGeloeschteBloecke

Exit Sub

BlFehler:

strBlName = ""

Resume Next

End Sub

Der Modellbereich kann nicht gelöscht werden. Er wird deshalb auch nicht in die Auflistung der gelöschten Blöcke aufgenommen.

Der Inhalt der Variablen strGeloeschteBloecke wird im Meldungsfenster ausgegeben.

Umbenennen von Blöcken

In AutoCAD können Sie Blöcke über das Menü Format/Umbennen oder den Befehle UMBENENN/Blöcke ändern.

Übung 17 Umbenennen

Die folgende Routine kann dazu verwendet werden, automatisch mehrere Blöcke umzubenennen.

Public Sub BloeckeUmbenennen()

Dim objBlock As AcadBlock

Dim strGeloeschteBloecke As String

'Ruft Funktion zum Erzeugen eines neuen Blocks auf

BlockErzeugen

'Zeigt die in der Zeichnung vorhandenen Blöcke an

BloeckeAuflisten

'Block umbenennen, falls der neue Name noch nicht existiert

On Error Resume Next

Set objBlock = Thisdrawing.Blocks.Item("NeuerBlock")

objBlock.Name = "NeuerNameFuerBlock"

'Zeigt die in der Zeichnung vorhandenen Blöcke an

BloeckeAuflisten

End Sub

WBlock-Methode

Ein Wblock wird im Gegensatz zu einem Block als eigenständige Zeichnung gespeichert.

Die folgende Prozedur erstellt zuerst über die unten beschriebenen Funktionen ZeichnenLwPolylinie und ZeichnenKreis 2 Objekte. Danach werden diese beiden Objekte in einen neuen Auswahlsatz aufgenommen.

Übung 18 Wblock erstellen

Die folgende Funktion erstellt das abgebildete Objekt und speichert es unter dem Namen C:\vba\BeispielWblock.dwg

Sub ErstellenWBlock()

'Erzeugen von Objekten, die dann als WBlock gespeichert werden

' On Error Resume Next

'Polylinie erzeugen

Dim objPlinie As AcadLWPolyline

Set objPlinie = ZeichnenLwPolylinie

objPlinie.Closed = True

'Kreis zeichnen

Dim objKreis As AcadCircle

Set objKreis = ZeichnenKreis

'Auswahlsatz löschen, falls er schon vorhanden ist

Dim objSset As AcadSelectionSet

Set objSset = Thisdrawing.SelectionSets.Item("WBlockSset")

objSset.Delete

'Auswahlsatz erzeugen

Set objSset = Thisdrawing.SelectionSets.Add("WBlockSset")

'Alle Zeichnungsobjekte auswählen und in den Auswahlsatz aufnehmen

ReDim objsInModelSpace(0 To Thisdrawing.ModelSpace.Count - 1) As AcadEntity

Dim inti As Integer

For inti = 0 To Thisdrawing.ModelSpace.Count - 1

Set objsInModelSpace(inti) = Thisdrawing.ModelSpace.Item(inti)

Next

'Objektfeld an den Auswahlsatz hinzufügen

objSset.AddItems objsInModelSpace

'Ausgabe der gewählten Objekte in eine Zeichnungsdatei (WBlock)

Thisdrawing.Wblock "c:\vba\BeispielWblock.dwg", objSset

ZoomExtents

End Sub

Übung 19 Funktion ZeichnenPolylinie

Diese Funktion wird in späteren Übungen immer wieder verwendet. Sie erzeugt eine LwPolylinie im Modellbereich.

Die Zuweisung der Objektvariable mit Set objLwPolylinie = ... erzeugt mit der Methode AddLwPolyline die Polylinie im Modellbereich.

Public Function ZeichnenLwPolylinie() As AcadLWPolyline

Dim dblPunkte(0 To 15) As Double

'2D-Punkte für Polylinie definieren

dblPunkte(0) = 100: dblPunkte(1) = 100

dblPunkte(2) = 100: dblPunkte(3) = 150

dblPunkte(4) = 125: dblPunkte(5) = 150

dblPunkte(6) = 125: dblPunkte(7) = 175

dblPunkte(8) = 175: dblPunkte(9) = 175

dblPunkte(10) = 175: dblPunkte(11) = 150

dblPunkte(12) = 200: dblPunkte(13) = 150

dblPunkte(14) = 200: dblPunkte(15) = 100

' Polylinie im Modellbereich zeichnen

Set ZeichnenLwPolylinie = Thisdrawing.ModelSpace.AddLightWeightPolyline(dblPunkte)

End Function

Übung 20 Funktion ZeichnenKreis

Diese Funktion wird in späteren Übungen immer wieder verwendet. Sie zeichnet einen Kreis im Modellbereich. Das Zentrum liegt im Punkt 100,100,0 und der Radius ist 30 Einheiten.

Die Zuweisung der Objektvariable mit Set objKreis = ... erzeugt mit der Methode AddCircle den Kreis im Modellbereich.

Public Function ZeichnenKreis() As AcadCircle

Dim dblZentrum(0 To 2) As Double

Dim dblRadius As Double

'Koordinaten fest definiert

dblZentrum(0) = 100: dblZentrum(1) = 100: dblZentrum(2) = 0

dblRadius = 30

'Zeichnen des Kreises

Set ZeichnenKreis = Thisdrawing.ModelSpace.AddCircle(dblZentrum, dblRadius)

End Function

Attribute

· Definition von Attributen

· Ändern von Attributen

· Auslesen von Attributen

Um eine Attributreferenz zu erstellen, müssen Sie zunächst in einem Block eine Attributdefinition erzeugen, indem Sie die AddAttribute-Methode verwenden. Diese Methode erfordert sechs Werte als Eingabe:

· Höhe des Attributtexts

· Attributmodus

· Eingabeaufforderung

· Einfügepunkt

· Attributbezeichnung

· Vorgabeattributwert

Der Wert für den Modus ist optional. Der Attributmodus kann durch die Eingabe von fünf verschiedenen Konstanten festgelegt werden:

Sie können keine, eine Kombination beliebiger oder alle Optionen angeben. Um mehrere Optionen gleichzeitig festzulegen, addieren Sie die Konstanten mit dem Pluszeichen.

Beispiel:

acAttributeModeInvisible + acAttributeModeConstant

Die Eingabeaufforderung für das Attribut wird beim Einfügen eines Blocks angezeigt, der diese Attributdefinition enthält. Die Vorgabeeinstellung für die Eingabeaufforderung ist die Zeichenfolge der Marke. Durch Eingabe von acAttributeModeConstant für den Modus wird die Eingabeaufforderung deaktiviert.

Die Attributbezeichnung kennzeichnet jedes Vorkommen eines Attributs in der Zeichnung. Die Bezeichnung kann alle Zeichen außer Leerzeichen und Ausrufezeichen (!) enthalten. AutoCAD ändert Kleinbuchstaben automatisch in Großbuchstaben.

Nachdem die Attributdefinition in einem Block definiert wurde, können Sie jedesmal, wenn Sie einen Block mit Hilfe der InsertBlock-Methode einfügen, einen anderen Wert für die Attributreferenz festlegen.

Eine Attributdefinition ist mit dem Block verknüpft, für den sie erstellt wurde. Im Modell- oder Papierbereich erzeugte Attributdefinitionen sind nicht mit einem bestimmten Block verknüpft.

Attributdefinition

In diesem Beispiel wird ein Block definiert und ein Attribut zur Blockdefinition hinzugefügt. Anschließend wird der Block in die Zeichnung eingefügt.

Übung 21 Erzeugen von Attributen

Sub ErzeugenAttribute()

'Block

Dim objBlock As AcadBlock

Dim dblEinpunkt(0 To 2) As Double

dblEinpunkt(0) = 100

dblEinpunkt(1) = 100

dblEinpunkt(2) = 0

Set objBlock = Thisdrawing.Blocks.Add(dblEinpunkt, "BlockMitAttribut")

Dim objKreis As AcadCircle

Dim dblZentrum(0 To 2) As Double

Dim dblRadius As Double

dblZentrum(0) = 100

dblZentrum(1) = 100

dblZentrum(2) = 0

dblRadius = 3

'Linien

Dim objLinie(0 To 1) As AcadLine

Dim dblStart1(0 To 2) As Double

Dim dblEnd1(0 To 2) As Double

Dim dblStart2(0 To 2) As Double

Dim dblEnd2(0 To 2) As Double

dblStart1(0) = 100: dblStart1(1) = 95: dblStart1(2) = 0

dblEnd1(0) = 100: dblEnd1(1) = 105: dblEnd1(2) = 0

dblStart2(0) = 95: dblStart2(1) = 100: dblStart2(2) = 0

dblEnd2(0) = 105: dblEnd2(1) = 100: dblEnd2(2) = 0

'Objekte zum Block hinzufügen

Set objKreis = objBlock.AddCircle(dblZentrum, dblRadius)

Set objLinie(0) = objBlock.AddLine(dblStart1, dblEnd1)

Set objLinie(1) = objBlock.AddLine(dblStart2, dblEnd2)

' Attribut hinzufügen

Dim objAttribut As AcadAttribute

Dim dblHoehe As Double

Dim lngModus As Long

Dim strPrompt As String

Dim strBezeichnung As String

Dim strWert As String

dblHoehe = 2.5

lngModus = acAttributeModeNormal

strPrompt = "Geben Sie den Namen des Herstellers ein: "

'Text höher positionieren

dblEinpunkt(1) = 105

strBezeichnung = "Hersteller"

strWert = "Schreinerei Huber"

Set objAttribut = objBlock.AddAttribute(dblHoehe, lngModus, _

strPrompt, dblEinpunkt, strBezeichnung, strWert)

'Block mit Attributen einfügen

Dim objblockRef As AcadBlockReference

Set objblockRef = Thisdrawing.ModelSpace.InsertBlock _

(dblEinpunkt, "BlockMitAttribut", 1, 1, 1, 0)

End Sub

Zeichnungsinformationen

Abstand

Nachfolgende Prozedur berechnet den Abstand, vergleichbar dem Befehle Abstand in AutoCAD.

Übung 22 Abstand

Sub AbstandBerechnen()

Dim varPunkt1 As Variant

Dim varPunkt2 As Variant

varPunkt1 = Thisdrawing.Utility.GetPoint _

(, vbCrLf & "Erster Punkt: ")

varPunkt2 = Thisdrawing.Utility.GetPoint _

(varPunkt1, vbCrLf & "Zweiter Punkt: ")

'diagonalen Abstand berechnen

Dim x As Double, y As Double, z As Double

Dim dblAb As Double

x = varPunkt2(0) - varPunkt1(0)

y = varPunkt2(1) - varPunkt1(1)

z = varPunkt2(2) - varPunkt1(2)

dblAb = Sqr((Sqr((x ^ 2) + (y ^ 2)) ^ 2) + (z ^ 2))

MsgBox "Abstand diagonal " & vbTab & dblAb & vbCrLf _

& "Abstand in x " & vbTab & x & vbCrLf _

& "Abstand y " & vbTab & y & vbCrLf _

& "Abstand z " & vbTab & z, , "Abstandsberechnung"

End Sub

ID-Punkt

Mit dem Befehl ID können Koordinaten eines gezeigten Punktes abgefragt werden. Die folgende Prozedur speichert die Koordinaten eines gezeigten Punktes in der Variablen varKoord und schreibt sie als Text neben den gezeigten Punkt. Wollen Sie den Text manuell plazieren, verwenden Sie Getpoint.

Übung 23 Koordinaten als Text neben gezeigten Punkt

Sub TextId()

Dim strText As String

Dim objEnt As AcadEntity

Dim varKoord As Variant

Dim objText As AcadText

varKoord = Thisdrawing.Utility.GetPoint(, "Klicken Sie den Punkt")

strText = "X:" & Format(varKoord(0), "#,##0.00") _

& " Y: " & Format(varKoord(1), "#,##0.00") _

& " Z:" & Format(varKoord(2), "#,##0.00")

Set objText = Thisdrawing.ModelSpace.AddText(strText, varKoord, 2.5)

objText.Update

End Sub

Übung 24 Textposition manuell zeigen

Damit die Textposition manuell gesetzt werden kann ändern Sie die Zeile Set objText... so, dass mit Getpoint ein Punkt gezeigt werden kann.

Sub TextId()

Dim strText As String

Dim objEnt As AcadEntity

Dim varKoord As Variant

Dim objText As AcadText

varKoord = ThisDrawing.Utility.GetPoint(, "Klicken Sie den Punkt")

strText = "X:" & Format(varKoord(0), "#,##0.00") _

& " Y: " & Format(varKoord(1), "#,##0.00") _

& " Z:" & Format(varKoord(2), "#,##0.00")

varKoord = ThisDrawing.Utility.GetPoint(, "Zeig mir, wo der Text stehen soll")

Set objText = ThisDrawing.ModelSpace.AddText(strText, varKoord, 2.5)

objText.Update

End Sub

Übung 25 Fläche

Bei folgenden Objekten kann mit der Area-Methode die Fläche direkt abgefragt werden. Ein einzelnes Polyliniensegment bildet keine Fläche. Bei 2 oder mehreren Segmenten, wird die Fläche des geschlossenen Linienzuges berechnet.

Die folgende Prozedur berechnet die Flächeninhalte aller geschlossenen Objekte (s.oben). Wenn ein Fehler auftaucht, wird er ignoriert. Die Objekte, für die keine Fläche berechnet werden kann, werden übersprungen.

Sub Flaeche()

Dim objEnt As AcadEntity

On error resume next

For Each objEnt In Thisdrawing.ModelSpace

MsgBox objEnt.Area

Next

End Sub

Übung 26 Kreisfläche

In der folgenden Prozedur werden die Flächeninhalte aller Kreise addiert und als Gesamtfläche ausgegeben.

Sub KreisFlaeche()

Dim objEnt As AcadEntity

Dim dblGesamtFl As Double

On Error Resume Next

For Each objEnt In Thisdrawing.ModelSpace

If objEnt.ObjectName = "AcDbCircle" Then

dblGesamtFl = dblGesamtFl + objEnt.Area

End If

Next

MsgBox dblGesamtFl

End Sub

Für die Praxis kann folgende Prozedur hilfreich sein. Sie zieht von einer gewählten Fläche eines Polygons Kreisflächen (Bohrungen) ab. Die Auswahl erfolgt über Fenster oder Polygon.

Übung 27 Plattenfläche berechnen

Wählen Sie einen Polygonzug, z.B. ein Rechteck, in welchem Bohrungen enthalten sind. Die Kreise werden von der Polygonfläche abgezogen.

Sub Plattenflaeche()

Dim objEnt As AcadEntity

Dim dblGesamtFl As Double

Dim objSset As AcadSelectionSet

Dim dblMinus As Double

Dim inti As Integer

On Error Resume Next

Set objSset = Thisdrawing.SelectionSets("NeueAuswahl")

objSset.Delete

Set objSset = Thisdrawing.SelectionSets.Add("NeueAuswahl")

objSset.SelectOnScreen

For Each objEnt In objSset

If objEnt.ObjectName = "AcDbPolyline" Or _

objEnt.ObjectName = "AcDbLwPolyline" Then

dblGesamtFl = dblGesamtFl + objEnt.Area

ElseIf objEnt.ObjectName = "AcDbCircle" Then

inti = inti + 1

dblMinus = dblMinus + objEnt.Area

End If

Next objEnt

dblGesamtFl = Format(dblGesamtFl, "#,##0.000")

dblMinus = Format(dblMinus, "#,##0.000")

MsgBox "Die Gesamtfläche beträgt: " & vbTab & dblGesamtFl & vbCrLf _

& "abzüglich " & inti & " Bohrungen " & vbTab & dblMinus & vbCrLf _

& "Die Endfläche beträgt " & vbTab & dblGesamtFl - dblMinus & " Quadrateinheiten"

End Sub

Zoombefehle

Zuerst wird ein Kreis, eine Polylinie und eine Ellipse gezeichnet.

Kreis zeichnen

Function ZeichnenKreis() As AcadCircle

Dim dblZentrum(0 To 2) As Double

Dim dblRadius As Double

'Koordinaten fest definiert

dblZentrum(0) = 100: dblZentrum(1) = 100: dblZentrum(2) = 0

dblRadius = 30

'Zeichnen des Kreises

Set ZeichnenKreis = Thisdrawing.ModelSpace.AddCircle(dblZentrum, dblRadius)

End Function

Polylinie zeichnen

Public Function ZeichnenPolylinie() As AcadPolyline

Dim dblPListe(0 To 14) As Double

dblPListe(0) = 10: dblPListe(1) = 10: dblPListe(2) = 0

dblPListe(3) = 10: dblPListe(4) = 20: dblPListe(5) = 0

dblPListe(6) = 20: dblPListe(7) = 20: dblPListe(8) = 0

dblPListe(9) = 30: dblPListe(10) = 20: dblPListe(11) = 0

dblPListe(12) = 40: dblPListe(13) = 40: dblPListe(14) = 0

' Erzeugt eine Polylinie im Modellbereich

Set ZeichnenPolylinie = Thisdrawing.ModelSpace.AddPolyline(dblPListe)

End Function

Ellipse zeichnen

Sub ZeichnenEllipse()

Dim objEll As AcadEllipse

Dim dblHptAchse(0 To 2) As Double

Dim dblZentrum(0 To 2) As Double

Dim dblVerhaelt As Double

dblZentrum(0) = 50#: dblZentrum(1) = 50#: dblZentrum(2) = 0#

dblHptAchse(0) = 100: dblHptAchse(1) = 0#: dblHptAchse(2) = 0#

dblVerhaelt = 0.5

Set objEll = Thisdrawing.ModelSpace.AddEllipse(dblZentrum, dblHptAchse, dblVerhaelt)

End Sub

Übung 28 Zoomen

Sub ZoomBefehle()

Dim dblPunkt1(0 To 2) As Double

Dim dblPunkt2(0 To 2) As Double

Call ZeichnenKreis

Call ZeichnenPolylinie

Call ZeichnenEllipse

' Alles zoomen

ZoomAll

MsgBox "Zoom alles ", , " Zoom Alles"

' Zoom Fenster

dblPunkt1(0) = 10: dblPunkt1(1) = 10: dblPunkt1(2) = 0

dblPunkt2(0) = 200: dblPunkt2(1) = 200: dblPunkt2(2) = 0

ZoomWindow dblPunkt1, dblPunkt2

MsgBox "Zoom Fenster mit den untenstehenden Koordinaten:" & vbCrLf & _

"10, 10, 0" & vbCrLf & _

"200, 200, 0", , "Zoom Fenster"

' Zoom Faktor

Dim dblSkalierFaktor As Double

Dim intSkaliertyp As Integer

dblSkalierFaktor = 2

intSkaliertyp = acZoomScaledRelative

ZoomScaled dblSkalierFaktor, intSkaliertyp

MsgBox "Zoom Faktor mit Skalierfaktor 2x relativ"

' Zoom Grenzen

ZoomExtents

MsgBox "Zoom Grenzen", , "Zoom Grenzen"

' Zoom Mitte

Dim dblZen(0 To 2) As Double

Dim dblVg As Double

dblZen(0) = 30: dblZen(1) = 30: dblZen(2) = 0

dblVg = 500

ZoomCenter dblZen, dblVg

MsgBox "Zoom Mitte:" & vbCrLf & _

" 30, 30, 0" & vbCrLf & _

"Höhe 500", , "Zoom Mitte"

End Sub

Ansichten und Ansichtsfenster

Papierbereich aktivieren

Gehen Sie wie folgt vor, um vom Modellbereich in das zuletzt aktive Papierbereichs-Layout umzuschalten:

ThisDrawing.ActiveSpace = acPaperSpace

ThisDrawing.MSpace = FALSE

ThisDrawing.ActivePViewport.Display TRUE

ThisDrawing.MSpace = TRUE

ANMERKUNG Bevor Sie versuchen, in den Modellbereich zu wechseln, müssen Sie zuerst verschiebbare Ansichtsfenster erstellen.

Modellbereich aktivieren

ThisDrawing.ActiveSpace = acModelSpace

Erzeugen von Ansichtsfenstern

Ansichtsfenster im Papierbereich werden mit der AddPViewport-Methode erstellt. Diese Methode benötigt die Angabe eines Mittelpunkts sowie der Breite und Höhe des neuen Ansichtsfensters. Bevor Sie das Ansichtsfenster erstellen, verwenden Sie die Eigenschaft ActiveSpace, um den Papierbereich als aktuellen Bereich festzulegen (normalerweise durch Setzen von TILEMODE auf 0).

Übung 29 Ansichtsfenster erzeugen

Sub PapierBereichMitAfenster()

' Papierbereich

Thisdrawing.ActiveSpace = acPaperSpace

' Mansfen erzeugen

Dim objMansFen As AcadPViewport

Dim dblMitte(0 To 2) As Double

dblMitte(0) = 45

dblMitte(1) = 70

dblMitte(2) = 0

Set objMansFen = Thisdrawing.PaperSpace. _

AddPViewport(dblMitte, 100, 140)

' Iso Südwest

Dim dblAPunkt(0 To 2) As Double

dblAPunkt(0) = -1

dblAPunkt(1) = -1

dblAPunkt(2) = 1

objMansFen.Direction = dblAPunkt

' anzeigen

objMansFen.Display True

' Modellbereich aktivieren

Thisdrawing.MSpace = True

'Ansicht aktivieren

Thisdrawing.ActivePViewport = objMansFen

' Zoom Grenzen

ZoomExtents

' Modellbereich deaktivieren

Thisdrawing.MSpace = False

' Papierbereich auf Grenzen zoomen

ZoomExtents

End Sub

Ansichtsfenster Inhalt

Zur Änderung der Ansicht eines Viewport-Objekts müssen Sie sich im Modellbereich befinden und das entsprechende Ansichtsfenster muss aktiv sein.

So bearbeiten Sie eine Zeichnung in einem verschiebbaren Ansichtsfenster

1 Aktivieren Sie das Ansichtsfenster im Modellbereich durch Definieren der ActiveViewport-Eigenschaft:

Thisdrawing.ActiveViewport = MyViewportObject

2 Bearbeiten Sie die Zeichnung.

Sie können im Papierbereich auch Objekte wie Maßtext, Bemaßungen und Schriftfelder erstellen. Dazu müssen Sie jedoch die ActiveSpace-Eigenschaft auf False setzen und den Papierbereich mit der MSpace-Eigenschaft aktivieren. Objekte, die im Papierbereich erstellt wurden, sind nur im Papierbereich sichtbar.

Löschen von Ansichtsfenstern

Ansichtsfenster relativ zum Papierbereich zoomen

Vor dem Plotten können Sie für jeden Abschnitt Ihrer Zeichnung genaue Skalierfaktoren zum Zoomen festlegen. Durch das Skalieren von Ansichten relativ zum Papierbereich wird für jede angezeigte Ansicht eine einheitliche Skalierung erreicht. Die folgende Abbildung beispielsweise zeigt eine Ansicht des Papierbereichs mit mehreren Ansichtsfenstern, jedes mit einer anderen Ansicht und unterschiedlicher Skalierung. Um die geplottete Zeichnung genau zu skalieren, müssen Sie jede Ansicht relativ zum Papierbereich skalieren, nicht relativ zur vorherigen Ansicht oder zur Größe des Modells.

Im Papierbereich stellt der Zoomfaktor das Verhältnis zwischen der Größe der geplotteten Zeichnung und der tatsächlichen Größe des in den Ansichtsfenstern angezeigten Modells dar. Dieses Größenverhältnis erhalten Sie, indem Sie Papierbereichseinheiten durch Modellbereichseinheiten teilen. So müssen Sie für eine Zeichnung im Maßstab 1:4 einen Skalierfaktor von einer Papierbereichseinheit zu vier Modellbereichseinheiten angeben.

Verwenden Sie die ZoomScaled-Methode, um Ansichtsfenster relativ zu den Papierbereichseinheiten zu skalieren. Diese Methode erfordert als Eingabe drei Werte: das zu skalierende Ansichtsfenster, den Skalierfaktor und die Anwendungsart des Skalierfaktors. Der dritte Wert ist optional und bestimmt, wie die Skalierung angewendet wird:

relativ zu den Zeichnungslimiten

relativ zur aktuellen Ansicht

relativ zu den Papierbereichseinheiten

Um den Skalierfaktor relativ zu den Papierbereichseinheiten festzulegen, geben Sie die Konstante acZoomScaledRelativePSpace für diesen Wert ein.

Wenn Sie einen Skalierfaktor von 2 relativ zu den Papierbereichseinheiten eingeben, vergrößert sich die Skalierung im Ansichtsfenster auf das Doppelte der Größe der Papierbereichseinheiten (siehe Abbildung). Ein Skalierfaktor von 0.5 relativ zu den Papierbereichseinheiten setzt die Skalierung auf die Hälfte der Papierbereichseinheiten. Die geplottete Ausgabe ist dann halb so groß wie das Modell.

Drucken von Zeichnungen

Im Plot-Objekt können Sie folgende Methoden und Eigenschaften verwenden:

SetLayoutsToPlot-Methode

Muss jeweils vor den Methoden PlotToDevice bzw. PlotToFile aufgerufen werden. Wenn SetLayoutsToPlot nicht bzw. mit einer NULL-Eingabe aufgerufen wird, wird das aktive Layout geplottet.

NumberOfCopies

Legt die Anzahl der zu plottenden Kopien fest. Wenn diese Eigenschaft nicht vor jedem PlotToDevice-Aufruf zurückgesetzt wird, wird der letzte in der Eigenschaft NumberOfCopies angegebene Wert verwendet.

QuietErrorMode

Plotten im Stapelmodus dient der Unterstützung des Dienstprogramms für Stapelplots. Bevor Sie einen Stapelplot starten, setzen Sie QuietErrorMode für eine ungestörte Plot-Sitzung auf TRUE.

StartBatchMode

Verwenden Sie zum Starten eines Stapelplots die Methode StartBatchMode.

BatchPlotProgress

Verwenden Sie die Methode BatchPlotProgress, um den Fortschritt des Stapelplots zu überprüfen und um den Stapelmodus zu beenden.

Beim Plotten einer großen Zeichnung, wie etwa eines Grundrisses, können Sie normalerweise einen Skalierfaktor zum Konvertieren der tatsächlichen Zeicheneinheiten in Zoll oder Millimeter im Ausdruck festlegen. Wenn Sie jedoch aus dem Modellbereich plotten und keine Einstellungen festgelegt sind, werden u. a. die Standards Plotten auf Systemdrucker, Plotten der aktuellen Anzeige, Größe angepaßt, 0-Drehung und 0,0-Abstand verwendet. Ändern Sie die Eigenschaften auf dem Layout-Objekt, das mit dem Modellbereich verknüpft ist, um die Ploteinstellungen zu verändern.

Plotten der Grenzen des aktiven Modellbereichs-Layouts

In diesem Beispiel wird zuerst überprüft, ob der Modellbereich der aktive Bereich ist. Dann werden verschiedene Ploteinstellungen definiert. Abschließend wird der Plot mit der PlotToDevice-Methode abgeschickt.

Übung 30 Plotten Grenzen

Sub PlottenModellBereich()

If Thisdrawing.ActiveSpace = acPaperSpace Then

Thisdrawing.MSpace = True

Thisdrawing.ActiveSpace = acModelSpace

End If

' Plotbereich festlegen

Thisdrawing.ModelSpace.Layout.PlotType = acExtents

Thisdrawing.ModelSpace.Layout. _

StandardScale = acScaleToFit

' 1 Kopie drucken

Thisdrawing.Plot.NumberOfCopies = 1

' Plot initialisieren

Thisdrawing.Plot.PlotToDevice

End Sub

Der Gerätename kann mit der Eigenschaft ConfigName festgelegt werden. Das festgelegte Gerät kann in der PlotToDevice-Methode durch Angabe einer PC3-Datei überschrieben werden.

Plotten aus dem Papierbereich

Sie können ein oder mehrere Papierbereichs-Layouts gleichzeitig plotten. Sie können das aktive Layout plotten, wie im vorangegangenen Abschnitt "Plotten aus dem Modellbereich" gezeigt, oder die zu plottenden Layouts nach Namen festlegen.

Plotten von zwei Papierbereichs-Layouts

Im folgenden Beispiel werden die Papierbereichs-Layouts "Layout1" und "Layout2" an das Standard-Plotgerät gesendet. Beachten Sie, dass diese beiden Layouts in der Zeichnung vorhanden sein müssen, damit dieser Code lauffähig ist. In diesem Beispiel wird zuerst ein Zeichenketten-Datenfeld erstellt, das die Namen der zu plottenden Layouts enthält. Dann wird dieses Datenfeld als Eingabe für die SetLayoutsToPlot-Methode verwendet. Danach wird die Anzahl der zu plottenden Exemplare eingestellt und zum Schluß der Plot an das Standardgerät gesendet.

Übung 31 Plotten von 2 Layouts

Sub PlottenPapierBereich()

' zu plottende Layouts

Dim strLayouts(0 To 1) As String

Dim varLayouts As Variant

strLayouts(0) = "Layout1"

strLayouts(1) = "Layout2"

varLayouts = strLayouts

Thisdrawing.Plot.SetLayoutsToPlot varLayouts

' 1 Kopie drucken

Thisdrawing.Plot.NumberOfCopies = 1

' Plot initialisieren

Thisdrawing.Plot.PlotToDevice

End Sub

Übung 32 Plotterkonfiguration

Sub LayoutsZumPlotten()

Dim Plot As AcadPlot, AddedLayouts() As String ,varLayoutListe As Variant

Dim objKreis As AcadCircle, dblZentrum(0 To 2) As Double, dblRadius As Double

Dim objLayout As AcadLayout intDatenFeldGroesse As Integer

Dim intStapelZaehler As Integer

'Kreisobjekt zeichnen

dblZentrum(0) = 50: dblZentrum(1) = 50: dblZentrum(2) = 0

dblRadius = 20

Set objKreis = Thisdrawing.ModelSpace.AddCircle(dblZentrum, dblRadius)

' Anfrage, welche Layouts geplottet werden sollen

For Each objLayout In Thisdrawing.Layouts

If MsgBox("Möchten Sie das Layout drucken: " & objLayout.Name, vbYesNo & vbQuestion) = vbYes Then

intDatenFeldGroesse = intDatenFeldGroesse + 1

ReDim AddedLayouts(1 To intDatenFeldGroesse)

AddedLayouts(intDatenFeldGroesse) = objLayout.Name

End If

Next

'keine Auswahl durch Benutzer

If intDatenFeldGroesse = 0 Then Exit Sub

'Objektarray mit den zu druckenden Layouts an den Drucker schicken

varLayoutListe = AddedLayouts

Set Plot = Thisdrawing.Plot

Plot.QuietErrorMode = False 'Keine Hinweise während des Plottens

Plot.NumberOfCopies = 1

'Start des Stapelplots

Plot.StartBatchMode intDatenFeldGroesse

For intStapelZaehler = 1 To intDatenFeldGroesse

Plot.SetLayoutsToPlot varLayoutListe 'Muss jedesmal zum Plotten aufgerufen werden

Plot.PlotToDevice 'auf Standarddrucker plotten

If Plot.BatchPlotProgress Then

If MsgBox("Möchten Sie abbrechen?", vbYesNo & vbQuestion) = vbYes Then

Plot.BatchPlotProgress = False

End If

Else

MsgBox "Ein Fehlerchen ist aufgetaucht!"

End If

Next

MsgBox "Fertig mit Drucken!"

End Sub

Verdeckt plotten

Wenn Ihre Zeichnung 3D-Flächen, Netze, extrudierte Objekte, Oberflächen oder Volumenkörper enthält, können Sie verdeckte Linien aus bestimmten Ansichtsfenstern entfernen, wenn Sie die Ansicht plotten.

Verwenden Sie die Eigenschaft RemoveHiddenLines für das entsprechende Ansichtsfenster, um Linien in Ansichtsfenstern des Papierbereichs (PViewport-Objekten) zu verdecken. Diese Eigenschaft erfordert einen Booleschen Wert. Bei Eingabe von TRUE werden verdeckte Linien nicht geplottet, bei Eingabe von FALSE werden verdeckte Linien geplottet.

Um verdeckte Linien in Modellbereichs-Ansichtsfenstern (Viewport-Objekten) nicht zu plotten, verwenden Sie die PlotHidden-Eigenschaft des Layout-Objekts. Diese Eigenschaft erfordert einen Booleschen Wert. Bei Eingabe von TRUE werden verdeckte Linien nicht geplottet, bei Eingabe von FALSE werden verdeckte Linien geplottet.

Übung 33 DXF-Konverter

Der Konverter öffnet alle DXF-Dateien eines ausgewählten Verzeichnisses und fügt sie in eine Vorlagezeichnung ein. Danach werden die Objekte nach bestimmten Vorgaben auf neue Layer übertragen und die Zeichnung wird bereinigt. Dann wird gespeichert.

Benötigt wird ein Formular

Ein Modul und ein wenig Programmcode

Die Textbox heißt „TxtVerzeichnis“

Die Schaltfläche Verzeichnis auswählen CommandButton1 und die Schaltfläche Zeichnung konvertieren CommandButton2.

Sie benötigen auch ein Modul.

Übung 34 API - Funktion

Der Programmcode für CommandButton1 beinhaltet eine API-Funktion (Advanced Programmers Interface). Über API-Funktionen kann man auf die Windows-Umgebung zugreifen. Es gibt eine umfangreiche Funktionssammlung auf der hervorragenden Internet-Seite www.activevb.de.

Private Sub CommandButton1_Click()

On Error Resume Next

Dim Filter$, Flags&, FileName$

Flags = OFN_FILEMUSTEXIST Or OFN_HIDEREADONLY Or _

OFN_PATHMUSTEXIST

Filter$ = "DXF (*.dxf)" & Chr$(0) & "*.dxf"

FileName = ShowOpen(Filter, Flags)

If Len(FileName) > 0 Then

Do While Right(FileName, 1) <> "\"

FileName = Left(FileName, Len(FileName) - 1)

Loop

End If

txtVerzeichnis = FileName

End Sub

Übung 35 Modul einfügen

Sie benötigen nun ein neues Modul für die API-Funtionen und Konstanten.

Option Explicit

Private Declare Function GetOpenFileName Lib "comdlg32.dll" _

Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) _

As Long

Private Declare Function GetSaveFileName Lib "comdlg32.dll" _

Alias "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) _

As Long

Private Type OPENFILENAME

lStructSize As Long

hwndOwner As Long

hInstance As Long

lpstrFilter As String

lpstrCustomFilter As String

nMaxCustFilter As Long

nFilterIndex As Long

lpstrFile As String

nMaxFile As Long

lpstrFileTitle As String

nMaxFileTitle As Long

lpstrInitialDir As String

lpstrTitle As String

Flags As Long

nFileOffset As Integer

nFileExtension As Integer

lpstrDefExt As String

lCustData As Long

lpfnHook As Long

lpTemplateName As String

End Type

Public Const OFN_FILEMUSTEXIST = &H1000

Public Const OFN_HIDEREADONLY = &H4

Public Const OFN_PATHMUSTEXIST = &H800

Public Const OFN_READONLY = &H1

Public Function ShowOpen(Filter$, Flags&) As String

Dim Buffer$, Result&

Dim ComDlgOpenFileName As OPENFILENAME

Buffer = String$(128, 0)

With ComDlgOpenFileName

.lpstrTitle = "Doppelklicken Sie eine Datei im gewünschten Pfad"

.lStructSize = Len(ComDlgOpenFileName)

.Flags = Flags

.nFilterIndex = 1

.nMaxFile = Len(Buffer)

.lpstrFile = Buffer

.lpstrFilter = Filter

End With

Result = GetOpenFileName(ComDlgOpenFileName)

If Result <> 0 Then

ShowOpen = Left$(ComDlgOpenFileName.lpstrFile, _

InStr(ComDlgOpenFileName.lpstrFile, _

Chr$(0)) - 1)

End If

End Function

Public Function ShowSave(Filter$, Flags&, _

hWnd, FileName$) As String

Dim Buffer$, Result&

Dim ComDlgOpenFileName As OPENFILENAME

Buffer = FileName & String$(128 - Len(FileName), 0)

With ComDlgOpenFileName

.lStructSize = Len(ComDlgOpenFileName)

'.hwndOwner = hWnd

.Flags = OFN_HIDEREADONLY Or OFN_PATHMUSTEXIST

.nFilterIndex = 1

.nMaxFile = Len(Buffer)

.lpstrFile = Buffer

.lpstrFilter = Filter

End With

Result = GetSaveFileName(ComDlgOpenFileName)

If Result <> 0 Then

ShowSave = Left$(ComDlgOpenFileName.lpstrFile, _

InStr(ComDlgOpenFileName.lpstrFile, _

Chr$(0)) - 1)

End If

End Function

Makro aufrufen

Der Makroaufruf befindet sich in einem Standardmodul.

Sub dxfstart()

UserForm1.Show

End Sub

Drücken Sie ALT+F8

Anzeigen des Formulars

Zeigt das Userformular1 an.

Sub dxfstart()

UserForm1.Show

End Sub

Commandbutton2

Ruft die Prozedur DxfKonvert auf.

Private Sub CommandButton2_Click()

DxfKonvert

End Sub

Die öffentlichen Variablen im Userformular.

Option Explicit

Public strDxfNamen As Variant

Public DateiName As Variant

Private Sub CommandButton1_Click()

On Error Resume Next

Dim Filter$, Flags&, FileName$

Flags = OFN_FILEMUSTEXIST Or OFN_HIDEREADONLY Or _

OFN_PATHMUSTEXIST

Filter$ = "DXF (*.dxf)" & Chr$(0) & "*.dxf"

FileName = ShowOpen(Filter, Flags)

If Len(FileName) > 0 Then

Do While Right(FileName, 1) <> "\"

FileName = Left(FileName, Len(FileName) - 1)

Loop

End If

txtVerzeichnis = FileName

End Sub

Private Sub CommandButton2_Click()

DxfKonvert

End Sub

Sub DxfKonvert()

Dim obj As AcadObject

Dim objl As AcadLine

Dim Speicherort As String

Dim test As AcadDocument

Dim strPfad As String

Dim strName As String

Dim strZName As String

Dim TemplateFileName As String

Dim i As Integer, j As Integer

Dim strSpeicherPfad As String

Dim mBereich As AcadModelSpace

On Error Resume Next

strPfad = Me.txtVerzeichnis

If strPfad = "" Then

MsgBox "Wählen Sie bitte einen Pfad aus"

Exit Sub

End If

If Right(strPfad, 1) <> "\" Then

strPfad = strPfad & "\"

End If

Dim importFile As String

Dim InsertPoint(0 To 2) As Double

Dim scalefactor As Double

Dim Np(0 To 2) As Double

'Einfügepunkt

Np(0) = 0: Np(1) = 0: Np(2) = 0

'DateinamenAuflisten

DateiName = Dir$(Me.txtVerzeichnis) 'Dir$("c:\temp\*.xls")

Do While DateiName <> ""

If Right(DateiName, 3) = "DXF" Or Right(DateiName, 3) = "dxf" Then 'MsgBox Dateiname

Set mBereich = ThisDrawing.ModelSpace

'Neue Zeichnung aus Vorlagedatei erstellen, Vorlagedatei muss vorhanden sein

TemplateFileName = "G:\Programme\MDT6\Template\DIN A4 -Color Dependent Plot Styles.dwt" 'Pfad anpassen

Set test = Documents.Add(TemplateFileName)

'Dateiname zum Einfügen

strName = txtVerzeichnis & DateiName

ThisDrawing.ActiveSpace = acModelSpace

With ThisDrawing

'Einfügen der Zeichnung

ThisDrawing.ModelSpace.InsertBlock Np, strName, 1, 1, 1, 0

'Ursprung des Blocks

.SendCommand "ursprung alle " & Chr(13)

End With

'Eigenschaften ändern

For Each obj In ThisDrawing.ModelSpace

'alle Farben außer 8 und Text

If obj.ObjectName = "AcDbText" And obj.Color <> 8 Then

obj.Layer = "033_Schrift_035"

End If

'magenta alles

If obj.Color = 6 Then

obj.Layer = "035_Bemaßung_025"

End If

'8er Text

If obj.ObjectName = "AcDbText" And obj.Color = 8 Then

obj.Layer = "034_Schrift_050"

End If

'grüne Linie

If obj.ObjectName = "AcDbLine" And obj.Linetype = "CONTINUOUS" And obj.Color = 3 Then

obj.Layer = "013_ausg_035"

End If

If obj.ObjectName = "AcDbLine" And obj.Linetype = "HIDDEN" And obj.Color = 3 Then

obj.Layer = "014_strichl_035"

End If

If obj.ObjectName = "AcDbLine" And obj.Linetype = "DASHDOT" And obj.Color = 3 Then

obj.Layer = "015_strichp_035"

End If

If obj.ObjectName = "AcDbLine" And obj.Linetype = "DOT" And obj.Color = 3 Then

obj.Layer = "016_punkt_035"

End If

'Verschiedene Linientypen grün

If obj.ObjectName = "AcDbLine" And obj.Linetype = "PHANTOM" And obj.Color = 4 Then

obj.Layer = "014_strichl_035"

End If

If obj.ObjectName = "AcDbLine" And obj.Linetype = "CENTER" And obj.Color = 4 Then

obj.Layer = "015_strichp_035"

End If

' Wie heißen die anderen Linientypen

If Not obj.Linetype = "DOT" And Not obj.Linetype = "HIDDEN" And Not _

obj.Linetype = "CONTINUOUS" And Not obj.Linetype = "CENTER" And Not _

obj.Linetype = "PHANTOM" And Not obj.Linetype = "DASHDOT" Then _

MsgBox obj.Linetype

End If

'blaue Linie

If obj.ObjectName = "AcDbLine" And obj.Linetype = "CONTINUOUS" And obj.Color = 5 Then

obj.Layer = "017_ausg_050"

End If

If obj.ObjectName = "AcDbLine" And obj.Linetype = "HIDDEN" And obj.Color = 5 Then

obj.Layer = "018_strichl_050"

End If

If obj.ObjectName = "AcDbLine" And obj.Linetype = "DASHDOT" And obj.Color = 5 Then

obj.Layer = "019_strichp_050"

End If

If obj.ObjectName = "AcDbLine" And obj.Linetype = "DOT" And obj.Color = 5 Then

obj.Layer = "020_punkt_050"

End If

'Verschiedene Linientypen blau

If obj.ObjectName = "AcDbLine" And obj.Linetype = "PHANTOM" And obj.Color = 5 Then

obj.Layer = "018_strichl_050"

End If

If obj.ObjectName = "AcDbLine" And obj.Linetype = "CENTER" And obj.Color = 5 Then

obj.Layer = "019_strichp_050"

End If

'Farbe 8 Linie

If obj.ObjectName = "AcDbLine" And obj.Linetype = "CONTINUOUS" And obj.Color = 8 Then

obj.Layer = "009_ausg_025"

End If

If obj.ObjectName = "AcDbLine" And obj.Linetype = "HIDDEN" And obj.Color = 8 Then

obj.Layer = "010_strichl_025"

End If

If obj.ObjectName = "AcDbLine" And obj.Linetype = "DASHDOT" And obj.Color = 8 Then

obj.Layer = "011_strichp_025"

End If

If obj.ObjectName = "AcDbLine" And obj.Linetype = "DOT" And obj.Color = 8 Then

obj.Layer = "012_punkt_025"

End If

' Verschiedene Linientypen 8

If obj.ObjectName = "AcDbLine" And obj.Linetype = "PHANTOM" And obj.Color = 8 Then

obj.Layer = "010_strichl_025"

End If

If obj.ObjectName = "AcDbLine" And obj.Linetype = "CENTER" And obj.Color = 8 Then

obj.Layer = "011_strichp_025"

End If

'cyan Linie

If obj.ObjectName = "AcDbLine" And obj.Linetype = "CONTINUOUS" And obj.Color = 4 Then

obj.Layer = "021_ausg_070"

End If

If obj.ObjectName = "AcDbLine" And obj.Linetype = "HIDDEN" And obj.Color = 4 Then

obj.Layer = "022_strichl_070"

End If

If obj.ObjectName = "AcDbLine" And obj.Linetype = "DASHDOT" And obj.Color = 4 Then

obj.Layer = "023_strichp_070"

End If

If obj.ObjectName = "AcDbLine" And obj.Linetype = "DOT" And obj.Color = 4 Then

obj.Layer = "024_punkt_070"

End If

' Verschiedene Linientypen blau

If obj.ObjectName = "AcDbLine" And obj.Linetype = "PHANTOM" And obj.Color = 4 Then

obj.Layer = "022_strichl_070"

End If

If obj.ObjectName = "AcDbLine" And obj.Linetype = "CENTER" And obj.Color = 4 Then

obj.Layer = "023_strichp_070"

End If

'magenta alle

If obj.Color = 6 Then

obj.Layer = "035_Bemaßung_025"

End If

' Farbe 9 alle

If obj.Color = 9 Then

obj.Layer = "095_Hilfslinie_strichl_025"

End If

'Verschiedene Linientypen cyan

If obj.ObjectName = "AcDbLine" And obj.Linetype = "PHANTOM" And obj.Color = 4 Then

obj.Layer = "024_strichl_070"

End If

If obj.ObjectName = "AcDbLine" And obj.Linetype = "CENTER" And obj.Color = 4 Then

obj.Layer = "024_strichl_070"

End If

Next

'Alle bereinigen

ThisDrawing.PurgeAll

ZoomExtents

' Export der Datei

If Right(strSpeicherPfad, 1) <> "\" Then strSpeicherPfad = strSpeicherPfad & "\"

Speicherort = strSpeicherPfad & strZName '(Left(importFile, Len(importFile) - 4)) 'evtl. Pfad anpassen, speichert derzeit in das Dxf-Verzeichnis

ThisDrawing.SaveAs (Speicherort)

ThisDrawing.Close (1)

strDxfNamen = strDxfNamen & vbCrLf & DateiName

End If

i = i + 1

DateiName = Dir$()

Loop

‘ Userform schließen

Unload UserForm1

End Sub

Farbe aller Objekte auf “Vonlayer” einstellen.

Sub FarbeAendern()

Dim objEnt As AcadEntity

For Each objEnt In ThisDrawing.ModelSpace

objEnt.Color = acByLayer

Next

End Sub

VBA für AutoCAD Teil 3 1

Einleitung 2

Fortsetzung von Teil 2 2

Spline 3

Schraffur 3

Text 5

MText 5

Punkt 6

Übung: Polylinie 6

Polylinie mit Kreisbogen 7

Region 7

Solid 8

Daten aus Excel einlesen 9

Ändern von Objekten 12

Kopieren 12

Löschen 13

Auflösen 14

Hervorheben 15

Spiegeln 16

Mirrtext 16

Schieben 17

Übung: Kreis erstellen und verschieben 17

Versetzen 18

Übung: Polylinie mit fest eingebenen Punkten. 18

Drehen 19

Skalieren 21

Reihe rechteckig 22

Reihe polar 23

Eigenschaften ändern 23

Objektfarbe 23

Layer-Eigenschaft 25

Linientyp-Eigenschaft 25

Sichtbarkeit-Eigenschaft 26

Ändern von 3D-Objekten bzw. Regionen 27

Schnittmenge 27

Differenz 27

Vereinigung 28

Masseneigenschaften 28

Volumenberechnung 28

Beschriftung 30

Beschriftung 30

Textstile 30

Erzeugen und setzen eines Textstils 30

Schriftart zuweisen 31

Textposition 31

Führungen 33

Bemaßungen 33

Bemaßungsstil 33

Bemaßungsstil erzeugen 34

Bemaßungsstil einstellen 34

Bemaßungsvariablen 34

Bemaßungsstil nach DIN 34

Ausgerichtete Bemaßung 38

Durchmesserbemaßung 38

Automatische Durchmesserbemaßung 38

Winkelbemaßung mit 3 Punkten 39

Radialbemaßung 39

Automatische Radiusbemaßung aller Kreise 41

Winkelbemaßung 42

Koordinatenbemaßung 42

Koordinatenbemaßung Erstellen 43

Toleranzen 43

Geometrischen Toleranz erstellen 44

Toleranzen: Systemvariablen 45

Auswahlsätze: Ergänzung 45

Auswahlauflistung durchlaufen 45

Zugriff auf Auswahlsätze 46

Methoden der Auswahlsätze 46

Hinzufügen zu einem Auswahlsatz 46

Entfernen aus dem Auswahlsatz 46

RemoveItems 47

Clear 47

Erase 47

Delete 47

Filtersätze 48

Filter: DXF-Codes für häufig verwendete Filter 48

Filter: Textobjekte 49

Filter: Linienbobjekte 49

Filter: Layer "Kon_035" 49

Filter: Farbe rot 49

Blöcke 49

Durchlaufen der Blocksauflistung 50

Erzeugen von Blöcken 50

Blockobjekte hinzufügen 52

Block einfügen 52

Auflösen von Blöcken 52

Einfügepunkt verändern 53

Papierbereichsobjekte in den Block aufnehmen 53

Objekte eines Blocks 53

Block mehrfach einfügen 53

Block neu definieren 54

Umbenennen von Blöcken 57

WBlock-Methode 57

Attribute 59

Attributdefinition 61

Zeichnungsinformationen 63

Abstand 63

ID-Punkt 63

Zoombefehle 66

Kreis zeichnen 66

Polylinie zeichnen 66

Ellipse zeichnen 67

Ansichten und Ansichtsfenster 68

Modellbereich aktivieren 68

Erzeugen von Ansichtsfenstern 68

Ansichtsfenster Inhalt 69

Löschen von Ansichtsfenstern 70

Ansichtsfenster relativ zum Papierbereich zoomen 70

Drucken von Zeichnungen 70

SetLayoutsToPlot-Methode 70

NumberOfCopies 71

QuietErrorMode 71

StartBatchMode 71

BatchPlotProgress 71

Plotten der Grenzen des aktiven Modellbereichs-Layouts 71

Plotten aus dem Papierbereich 72

Plotten von zwei Papierbereichs-Layouts 72

Verdeckt plotten 73

Makro aufrufen 77

Anzeigen des Formulars 78