---

Hallo alle zusammen,

ich hoffe es kann mir jemand weiter helfen. Ich möchte aus Access per VBA eine CAD Zeichnung erstellen. In dieser Zeichnung soll ein Block entstehen.dieser Block soll kopiert werden. Den Atributen jedes Blocks soll der Inhalt eines Datensatzes zugeordnet werden. Es handelt sich dabei um 3 - dimensionale Meßpunkte.
Leider bin ich im VBA in ACAD totaler Neuling, im Access ist es schon besser.
Dank STELLI1 hab ich immerhin schon mal einen Ansatz gefunden und kann immerhin schon mal Punkte einfügen.

Hoffendlich bis bald

Chaó
el Cuervo

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

---

Hallo el Cuervo,

Stelli hat Dir ja schon beschrieben wie Du auf die AutoCAD Objekte zugreifst.

Schau Dir doch mal folgendes Beispiel aus dem
Entwicklerhandbuch für ActivX und VisualBasic
- erweiterte Zeichen- und Strukturierungsfunktionen
  - verwenden von Blöcken und Attributen an

Code:

---

Sub Ch10_InsertingABlock()
    ' Definieren des Blocks
    Dim blockObj As AcadBlock
    Dim insertionPnt(0 To 2) As Double
    insertionPnt(0) = 0
    insertionPnt(1) = 0
    insertionPnt(2) = 0
    Set blockObj = ThisDrawing.Blocks.Add _
                    (insertionPnt, "CircleBlock")

    ' Hinzufügen eines Kreises zum Block
    Dim circleObj As AcadCircle
    Dim center(0 To 2) As Double
    Dim radius As Double
    center(0) = 0
    center(1) = 0
    center(2) = 0
    radius = 1
    Set circleObj = blockObj.AddCircle(center, radius)

    ' Einfügen des Blocks
    Dim blockRefObj As AcadBlockReference
    insertionPnt(0) = 2
    insertionPnt(1) = 2
    insertionPnt(2) = 0
    Set blockRefObj = ThisDrawing.ModelSpace.InsertBlock _
              (insertionPnt, "CircleBlock", 1#, 1#, 1#, 0)
    ZoomAll
    MsgBox "Der Kreis gehört zu " & blockRefObj.ObjectName
End Sub

---

Hier wird zunächst ein Block definiert und dieser dann in die Zeichnung eingefügt.
Entsprechen der AddCircle-Methode gibt es auch eine AddAttribut-Methode
Die Attribute kannst Du dann nach dem Einfügen über .getAttribut füllen.

Grüße,
Klaus

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

---

Hallo Klaus,

danke für den Tipp, hab so einiges gefunden und werde hoffendlich bald etwas klarer sehen.

Chaó
el cuervo

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

---

  Hab doch noch ein Problem;
ich will wissen, ob es in der Zeichung meinen Block schon gibt. mein Ansatz ist folgender:

  Dim revisor
  Set revisor = Thisdrawing.Blocks
  If revisor.Item(i).Name = "mein Block" Then
  MsgBox "Block vorhanden"
  Exit Sub
  end if

aber das läuft nicht. mit ...Thisdrawing.Blocks.Count habe ich auch kein Glück. hat evtl. jemand eine Idee?

Chaó
cuervo

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

---

Hi cuervo,

Du musst auch deinen revisor durchlaufen um an die einzelnen Blöcke in der Zeichnung ranzukommen. Welchen Wert hat den i bei dir?!

Probiers mal so:

Code:

---

Public Sub lala()
Dim ent As AcadBlock
For Each ent In ThisDrawing.Blocks
MsgBox ent.Name
Next ent
End Sub

---

Gruß, Carsten

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

---

Oder als Function:

Code:

---

Function Block_vorhanden(Test As String)

  Dim ent As AcadBlock
  For Each ent In ThisDrawing.Blocks
    If ent.Name = Test Then
      Block_vorhanden = True
      Exit Function
    End If
  Next ent
  Block_vorhanden = False

End Function

---

Grüße,
Klaus

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

---

Vielen Dank für die schnellen Antworten.
Paßt sich wunderbar in mein Script ein.

einen schönen Tag

cuervo 

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

---

Hallo nochmal,

mein Skript funktioniert soweit ganz gut. nur möchte ich jetzt einen bestehenden Block aufrufen und seine Attribute ändern.

Im Handbuch gibt es da auch ein schönes Beispiel ("Extrahieren von Attributinformationen")
aber leider gibt es beim erneuten Durchlauf das Problem, dass die Attribute nicht überschrieben sonndern dazugeschrieben werden. mein versuch die Attribute mit delete zu löschen war nicht so clever.

evtl. kennt ja einer eine Lösung.

Chaò
cuervo

PS: hier noch mein Stand

Code:

---

    Dim ent As AcadBlock
    For Each ent In Thisdrawing.Blocks
    If ent.Name = "MESSPUNKT" Then Blocktest = True
    Next ent
 
    Set blockObj = Thisdrawing.Blocks.Add _
                    (Einfuegepkt2, "MESSPUNKT")
    Dim attributeObj As AcadAttribute
    Dim attributeObj1 As AcadAttribute
    Dim attributeObjP As ACAD_POINT
    If Blocktest = True Then
      attributeObj.Delete
      attributeObj1.Delete
    If Blocktest = False Then Set attributeObjP = blockObj.AddPoint(Einfuegepkt2)
    End If

---

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

---

Hallo cuervo,
schau Dir mal diesen Artikel an, da solltest Du alles finden.
Schönen Tag,
Klaus

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

---

Hallo Klaus,

inzwischen hab ich eine andere Lösung gefunden. Aber trotzdem danke für die superschnelle Antwort, war ein guter Tipp.
Ich habe mit einem Zähler einen anderen Blocknamen erstellen lassen.

etwa so :

Code:

---

    Dim ent As AcadBlock
    Dim BlockName As String
    Dim BlockTest As String
    Dim Contador As Double
   
    BlockName = "MESSPUNKT"
    BlockTest = "MESSPUNKT"
    For Each ent In Thisdrawing.Blocks
    If ent.Name = BlockName Then
    BlockName = BlockTest & "_" & Contador
    Contador = Contador + 1
    End If
    Next ent
 
    Set blockObj = Thisdrawing.Blocks.Add (Einfuegepkt2, BlockName)

---

Chaò
Cuervo

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

---

Hallo Cuervo,
so ganz verstehe ich das nicht.

Du erzeugst eine Kopie eines Blockes in der Blockdefinitionstabelle Deiner Zeichnung?
Wenn Du das Design Center öffnest hast Du jetzt praktisch zwei mal den gleichen Block mit unterschiedlichen Namen. Ist es das was Du möchtest?

Oder willst Du einen Block in die Zeichnung eintragen und die Attribute mit den Werten Deiner Messungen versehen. Dann mußt Du:
- Erst prüfen ob Dein Block schon vorhanden ist
- Diesen evtl. erzeugen (Methode .ADD )
- Diesen in die Zeichnung einfügen ( Methode .insertBlock )
- Prüfen ob Attribute vorhanden sind ( .has Attribute )
- diese ändern (siehe oben erwähnten Artikel)

Wenn Du das so machst hast Du Kopien eines Blockes in der Zeichnung, d.h. wenn Du die Blockdefinition änderst sind auch alle Kopie geändert, andernfalls müsstest Du jeden Block einzeln ändern.

Oder lieg ich da falsch? Beschreib doch mal den Sinn Deines Programmes.

Grüße,
Klaus

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

---

Hallo Klaus,

das Problem ist das ich zwar weiß das der Block vorhanden ist, aber nicht wo. Eigendlich wollte ich den Block quasi im Design Center finden und ändern. Das geht leider nicht.

Der Sinn des Programmes ist, aus einer Access Tabelle Punkte im ACAD dreidimensional darzustellen. Dabei soll ein bestimmter Block verwendet werden. dieser Block wird in der Routine erstellt und aus der Access Tabelle mit Daten gefüttert.
Für den Fall, das der Nutzer einige Daten vergessen hat und nachtragen will, soll in dieselbe Datei die Routine die nächsten Daten auslesen.

Inzwischen bin ich dahin gekommen, temporär eine Blockreferenz bei 0,0,0 einzufügen um dem Programm zu zeigen welchen Block ich meine, um sie später irgendwie wieder zu entfernen.
der zweite Blockhat allerdings den Vorteil, das man die eingelesenen Datensätze relativ einfach auseinanderhalten kann.
Ich werde berichten wie das Ergebnis dann wirklich aussieht.

Chaó
cuervo

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

---

Dann ist es ja genau so wie ich vermutet hatte.

Frage ist nur, soll der Block auch noch Attribute (Texte wie PktNr, Höhenanschrieb, Baumdurchmesser oder ähnliches) haben oder reicht ein Block (oder gar ein einfacher Acad_Point zur Darstellung.

Ansonsten ist Dein Vorgehen schon richtig. Untersuchen in BLOCKS ob der gewünschte Block schon vorhanden ist, wenn nicht einen neuen an der Stelle 0,0,0 erzeugen und diesen dann im Modellspace mit insertBlock einfügen.
Der neu erzeugte Block sollte aber nicht temporär sein, da er ja als Referenzobjekt für die im Modell eingefügten Blöcke dient. Meines Erachtens kann Du diesen Block auch erst dann löschen wenn alle Kopien im Modellbereich entfernt wurden (ähnlich dem Bereinigen).

Wenn Du schreibst Du hast Daten die aus der Accesstabelle eingefügt werden sollen wirst Du auch einen Block mit Attributen benötigen. Üblicherweise verwendet man die Feldnamen aus Access ganz gerne als Attributnamen  varAttribute().TagString, die Feldinhalte werden in den varAttribut().TextString geschrieben.

Schau Dir doch mal das getAttributes Beispiel an. Dort wird ein Block mit ein Attribut erzeugt und angezeigt.
im hasAttributes werden zwei Blöcke erzeugt ( einer mit einer ohne Attributen)

Grüße,
Klaus

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

---

Das mit dem Block sieht so aus:

Der Block beinhaltet einen Punkt (AddPoint) und zwei Attribute(AddAttributes). Ein Attribut bekommt die Punktnummer der andere die Höhe. nach dem erstellen wird der Block eingesetzt. Dabei werden bei jedem Einsetzen die Daten aus der Tabelle übernommen.
Noch ist es kein Problem, die Attribute jeweils neu zu bezeichnen (.TextString).

Ist die Routine jedoch einmal abgeschlossen, wird es problematisch den selben Block wieder zu aktivieren und die Attribute zu bezeichnen.

Daher soll ein "Dummy" eingefügt werden. Um jedoch beim Nutzer keine Verwirrung zu stiften (die Datei soll später als Arbeitsgrundlage dienen) muß der "Dummy" hernach verschwinden.

Die einfachere Methode ist eben die, einfach einen neuen Block zu erstellen.

Chaó
cuervo

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

---

Block_Vorhanden.zip

Hab Dir mal ein Beispiel angehängt wie so was geht:

Programm frägt Namen des Blockes und Einfügepunkt in der Befehlszeile ab
Wenn der Block noch nicht vorhanden ist wird er erzeugt und eine automatisch hochzählende Punktnummer und Höhe eingetragen.
Abbruch wenn kein Blockname mehr eingegeben wird.

Vielleicht hilft es Dir ja weiter, ansonsten müßtest Du den Code mal hier reinstellen.

Grüße,
Klaus

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

---

Hallo Klaus,

die zweite Variante mit dem Dummy klappt bei mir nicht recht
der Code sieht folgendermaßen aus:

Code:

---

Call GetDrawing            ' Modul sieht nach ob Acad geladen ist
 
If Not GetDrawing Then
    Dim Acad As String
        Acad = Dir("C:\Programme\AutoCAD*", vbDirectory)
        Acad = "c:\Programme\" & Acad & "\acad.exe"
        Shell Acad, vbMaximizedFocus
       
      ' Prüfen ob Zeichnung zur verfügung steht
      While Not GetDrawing
          MsgBox "AutoCAD steht nicht zur Verfügung", vbCritical
        Wend
       
End If
    ' Sanduhr
  Screen.MousePointer = 0
        Dim blockRefObj As AcadBlockReference

    Dim blockObj As AcadBlock
    Dim Einfuegepkt(0 To 2) As Double
    Einfuegepkt(0) = 2#
    Einfuegepkt(1) = 0.5
    Einfuegepkt(2) = 0#
    Dim Einfuegepkt1(0 To 2) As Double
    Einfuegepkt1(0) = 2#
    Einfuegepkt1(1) = -1#
    Einfuegepkt1(2) = 0#
    Dim Einfuegepkt2(0 To 2) As Double
    Einfuegepkt2(0) = 0#
    Einfuegepkt2(1) = 0#
    Einfuegepkt2(2) = 0#
    Dim ent As AcadBlock
    Dim BlockName As String
    Dim BlockTest As String
    Dim Contador As Double
   
    BlockName = "MESSPUNKT"
    BlockTest = "MESSPUNKT"
    For Each ent In Thisdrawing.Blocks
    If ent.Name = BlockName Then
    Set blockRefObj = blockObj.InsertBlock(Einfuegepkt2, BlockName, 1#, 1#, 1#, 0)
    End If
    Next ent
 
    Set blockObj = Thisdrawing.Blocks.Add _
                    (Einfuegepkt2, BlockName)
    ' Hinzufügen eines Attributs zum Block
    Dim attributeObj As AcadAttribute
    Dim attributeObj1 As AcadAttribute
    Dim attributeObjP As ACAD_POINT
   
    Dim height As Double
    Dim mode As Long
    Dim prompt As String
    Dim insertionPoint(0 To 2) As Double
    Dim tag As String
    Dim value As String
    Dim referenz As AcadObject
   
    Set attributeObjP = blockObj.AddPoint(Einfuegepkt2)
     
    height = 0.5
    mode = acAttributeModeVerify
    prompt = "Neue Eingabeaufforderung"

    tag = "Neuer Tag1"
    value = "Neuer Wert1"

    Set attributeObj = blockObj.AddAttribute(height, mode, _
                          prompt, Einfuegepkt, tag, value)
    tag = "Neuer Tag2"
    value = "Neuer Wert2"
    Set attributeObj1 = blockObj.AddAttribute(height, mode, _
                          prompt, Einfuegepkt1, tag, value)
    Dim rst As DAO.Recordset
    Dim EinfPkt(0 To 2) As Double
    Dim ScalGr As Double
    Dim scalMi As Double
    Dim scalKl As Double
    Set rst = Me.RecordsetClone
    If rst.RecordCount = 0 Then
    MsgBox "Sie haben keine Punkte ausgewählt", vbCritical
    Exit Sub
    End If
    rst.MoveFirst
    Do Until rst.EOF
    EinfPkt(0) = rst.Fields("Rechtswert").value
    EinfPkt(1) = rst.Fields("Hochwert").value
    EinfPkt(2) = rst.Fields("Höhe").value
    attributeObj.TextString = ""
    attributeObj.TextString = rst.Fields("Höhe")
    attributeObj.Update
    attributeObj1.TextString = ""
    attributeObj1.TextString = rst.Fields("PNR")
    attributeObj1.Update
    Set blockRefObj = Thisdrawing.ModelSpace.InsertBlock(EinfPkt, BlockName, 1#, 1#, 1#, 0)
    rst.MoveNext

    attributeObj.TextString = ""
    attributeObj.Update
    attributeObj1.TextString = ""
    attributeObj1.Update
    Loop
    rst.Close

---

das mit dem neuen Block klappt auf jeden Fall.

evtl. ist es ja nur eine Kleinigkeit die ich vergessen habe.

Chaó

el cuervo

PS: kleiner Hinweis ich arbeite aus Access heraus, nicht direkt im Acad.

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

---

Hallo Cuervo,

ich habe mit Deinem Code ein paar Probleme (sehr unübersichtlich)

Zunächst: Ist GetDrawing eine Funktion oder ein Sub ?
Du rufst es zweimal direkt hintereinander auf
Anschließend landest Du in einer Endlosschleife wenn AutoCAD nicht zur Verfügung steht.

Jetzt prüfst Du ob der Block vorhanden ist.
Findest Du ihn soll eine Kopie in die Zeichnung eingefügt werden.
Nur sollte hier nicht BlockObj.InsertBlock stehen sondern
ThisDrawing.ModelSpace.InsertBlock
Du willst den Block ja in die Zeichnung einfügen und nicht in den Block
Danach müßte die for - Schleife über ein exit for verlassen werden, denn der Block wurde ja gefunden. Das Einfügen ist eigendlich auch nicht nötig, das machst Du ja später über den RecordSet.

Die nachfolgenden Zeilen dürfen nur durchlaufen werden, wenn kein Block vorhanden ist, also ein neuer erzeugt werden muß.

Beim Einfügen in der Do until rst.eof Schleife solltest Du auch wie im Beispiel vorgehen
Zunächst wie richtig gemacht den Block einfügen, dann aber die Attribute anders zuweisen
Du hast doch das Beispiel bereits:

    If blockRefObj.HasAttributes Then
   
      ' Get the attributes for the block reference
      varAttributes = blockRefObj.GetAttributes
   
      ' Move the attribute tags and values into a string to be displayed in a Msgbox
      For I = LBound(varAttributes) To UBound(varAttributes)
        Select Case varAttributes(I).TagString
          Case "Neuer Tag1": varAttributes(I).TextString = rst.Fields("PNR")
          Case "Neuer Tag2": varAttributes(I).TextString = rst.Fields("Höhe")
        End Select
      Next
    End If
    blockRefObj.Update

Ungetestet - bin mir nicht ganz sicher ob die Zuweisung aus dem RecordSet so stimmt
Noch ein Tip: probiers mal mit strukturierter Programmierung und nicht einfach drauf los.

Grüße,
Klaus

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

---

Ich hab die Sache jetzt etwas anders gelöst und den Kollegen gefällt es soweit.
Für alle, die ein ähnliches Problem haben hier mal mein Script:

Code:

---

Private Sub BT_zeichnen_Click()
  On Error GoTo Err_BT_zeichnen_Click
'-------------------Variablen deklarieren------------
                                                    '*
    Dim blockObjP As AcadBlock                      '*
    Dim blockObjH As AcadBlock                      '*
    Dim ent As AcadBlock                            '*
    Dim Einfuegepkt(0 To 2) As Double              '*
    Einfuegepkt(0) = 2#                            '*
    Einfuegepkt(1) = 0.5                            '*
    Einfuegepkt(2) = 0#                            '*
    Dim Einfuegepkt1(0 To 2) As Double              '*
    Einfuegepkt1(0) = 2#                            '*
    Einfuegepkt1(1) = -1#                          '*
    Einfuegepkt1(2) = 0#                            '*
    Dim Einfuegepkt2(0 To 2) As Double              '*
    Einfuegepkt2(0) = 0#                            '*
    Einfuegepkt2(1) = 0#                            '*
    Einfuegepkt2(2) = 0#                            '*
    Dim BlockNameP As String                        '*
    Dim BlockTestP As String                        '*
    Dim ContadorP As Double                        '*
    Dim Kontrolle As Boolean                        '*
    Dim BlockNameH As String                        '*
    Dim BlockTestH As String                        '*
    Dim ContadorH As Double                        '*
    Dim NewLayerH As AcadLayer                      '*
    Dim NewLayerP As AcadLayer                      '*
    Dim attributeObj As AcadAttribute              '*
    Dim attributeObj1 As AcadAttribute              '*
    Dim attributeObjPP As ACAD_POINT                '*
    Dim attributeObjPH As ACAD_POINT                '*
    Dim height As Double                            '*
    Dim mode As Long                                '*
    Dim prompt As String                            '*
    Dim insertionPoint(0 To 2) As Double            '*
    Dim tag As String                              '*
    Dim value As String                            '*
    Dim blockRefObj As AcadBlockReference          '*
    Dim EinfPkt(0 To 2) As Double                  '*
    Dim ScalGr As Double                            '*
    Dim scalMi As Double                            '*
    Dim scalKl As Double                            '*
    Dim Acad As String                              '*
    Dim rst As DAO.Recordset                        '*
    Dim WarteZeit As Single                        '*
    Dim Zeit As Single                              '*
    Dim revisor                                    '*
                                                    '*
'----------Kontrolle ob Daten im Speicher------------
                                                    '*
Call GetDrawing                                    '*
  Set rst = Me.RecordsetClone                      '*
  If rst.RecordCount = 0 Then                      '*
  MsgBox "Sie haben keine Punkte im Speicher." _
  , vbCritical                                    '*
  rst.Close                                        '*
    DoCmd.Close acForm, "frm_NachAcadAuslesen"      '*
    DoCmd.OpenForm "frm_DateiSucheAnzeige"          '*
  GoTo weiter                                      '*
End If                                              '*
                                                    '*
'----------Kontrolle ob ACAD geladen ist--------------
                                                    '*
If Not GetDrawing Then                              '*
        Acad = Dir("C:\Programme\AutoCAD*" _
        , vbDirectory)                              '*
        Acad = "c:\Programme\" & Acad & "\acad.exe" '*
        Shell Acad, vbMaximizedFocus                '*
      ' Prüfen ob Zeichnung zur verfügung steht    '*
      While Not GetDrawing                        '*
            WarteZeit = 2                          '*
            Zeit = Timer + WarteZeit                '*
            If Zeit > 86400 Then Zeit = 86400      '*
            While Zeit > Timer                      '*
                DoEvents                            '*
                DBEngine.Idle                      '*
            GetAcad                                '*
            Wend                                    '*
        Wend                                        '*
End If                                              '*
                                                    '*
'-----------------------Sanduhr an--------------------
                                                    '*
  Screen.MousePointer = 11                        '*
                                                    '*
'----------Scalierfaktor für die Bolckreferenzen------
'*
          If Liste = "groß" Then revisor = 1#  '*
          If Liste = "mittel" Then revisor = 0.5 '*
          If Liste = "klein" Then revisor = 0.2 '*
                                                    '*
'----------------Blocknamen generieren----------------
                                                    '*
                'Blocknamen für Messpunkt          '*
    Kontrolle = False                              '*
    BlockNameP = "MESSPUNKT"                        '*
    BlockTestP = "MESSPUNKT"                        '*
    For Each ent In Thisdrawing.Blocks              '*
    If ent.Name = BlockNameP Then                  '*
    Kontrolle = True                              '*
    BlockNameP = BlockTestP & "_" & ContadorP      '*
    ContadorP = ContadorP + 1                      '*
    End If                                        '*
    Next ent                                        '*
                                                    '*
            ' Blocknamen für Höhenpunkt            '*
                                                    '*
    BlockNameH = "HÖHENPUNKT"                      '*
    BlockTestH = "HÖHENPUNKT"                      '*
    For Each ent In Thisdrawing.Blocks              '*
    If ent.Name = BlockNameH Then                  '*
    BlockNameH = BlockTestH & "_" & ContadorH      '*
    ContadorH = ContadorH + 1                      '*
    End If                                        '*
    Next ent                                        '*
                                                    '*
'-------------------Layer anlegen---------------------
                                                    '*
    Set NewLayerH = Thisdrawing.Layers.Add("Hoehe") '*
    NewLayerH.Color = 1                            '*
    Set NewLayerP = Thisdrawing.Layers.Add("PNR")  '*
    Thisdrawing.ActiveLayer = NewLayerP            '*
                                                    '*
'------Hinzufügen eines Attributs zu den Blöcken------
                'erstellen der Blöcke              '*
                                                    '*
    height = 0.5                                    '*
    mode = acAttributeModeVerify                    '*
    prompt = "Neue Eingabeaufforderung"            '*
                                                    '*
                'Block Punktnummer                  '*
                                                    '*
            Set blockObjP = Thisdrawing.Blocks.Add _
                    (Einfuegepkt2, BlockNameP)    '*
                                                    '*
    Set attributeObjPP = blockObjP.AddPoint _
                                    (Einfuegepkt2)  '*
                                                    '*
    tag = "Neuer Tag2"                              '*
    value = "Neuer Wert2"                          '*
    Set attributeObj1 = blockObjP.AddAttribute _
  (height, mode, prompt, Einfuegepkt1, tag, value) '*
                                                    '*
                'Layer Hoehe aktuell                '*
    Thisdrawing.ActiveLayer = NewLayerH            '*
                                                    '*
                'Block Hoehenpunkt                '*
                                                    '*
    tag = "Neuer Tag1"                              '*
    value = "Neuer Wert1"                          '*
    Set blockObjH = Thisdrawing.Blocks.Add _
    (Einfuegepkt2, BlockNameH)                      '*
                                                    '*
    Set attributeObjPH = blockObjH.AddPoint _
    (Einfuegepkt2)                                  '*
                                                    '*
    Set attributeObj = blockObjH.AddAttribute _
    (height, mode, prompt, Einfuegepkt, tag, value) '*
                                                    '*
'-------------------Punkte setzen---------------------
                                                    '*
    rst.MoveFirst                                  '*
    Do Until rst.EOF                                '*
    EinfPkt(0) = rst.Fields("Y_Wert").value        '*
    EinfPkt(1) = rst.Fields("X_Wert").value        '*
    EinfPkt(2) = rst.Fields("Z_Wert").value        '*
    attributeObj.TextString = ""                    '*
    attributeObj.TextString = rst.Fields("Z_Wert")  '*
    attributeObj.Update                            '*
    attributeObj1.TextString = ""                  '*
    attributeObj1.TextString = rst.Fields("PNR")    '*
    attributeObj1.Update                            '*
                                                    '*
    Thisdrawing.ActiveLayer = NewLayerP            '*
                                                    '*
    Set blockRefObj = Thisdrawing.ModelSpace. _
    InsertBlock(EinfPkt, BlockNameP, revisor _
    , revisor, revisor, 0)                          '*
                                                    '*
    Thisdrawing.ActiveLayer = NewLayerH            '*
                                                    '*
    Set blockRefObj = Thisdrawing.ModelSpace. _
    InsertBlock(EinfPkt, BlockNameH, revisor, _
    revisor, revisor, 0)                            '*
                                                    '*
    rst.MoveNext                                    '*
                                                    '*
    attributeObj.TextString = ""                    '*
    attributeObj.Update                            '*
    attributeObj1.TextString = ""                  '*
    attributeObj1.Update                            '*
    Loop                                          '*
    rst.Close                                      '*
                                                    '*
'-------------------Zoom auf alles--------------------
                                                    '*
    Thisdrawing.Application.ZoomAll                '*
                                                    '*
'-------------------Sanduhr aus-----------------------
                                                    '*
    Screen.MousePointer = 0                        '*
                                                    '*
'-----------------Layer "Hoehe" aktuell---------------
                                                    '*
weiter:                                            '*
                                                    '*
    Thisdrawing.ActiveLayer = NewLayerH            '*
                                                    '*
Exit_BT_zeichnen_Click:
    Exit Sub

Err_BT_zeichnen_Click:
    MsgBox Err.Description
    Resume Exit_BT_zeichnen_Click
   

End Sub

---

man kann nun bei der Bearbeitung entweder den Layer mit der Höhe oder den mit der Punktnummer ausschalten.außerdem hab ich noch eine Scalierung für die Meßpunktgröße eingebaut. wer will kann die auch über eine Zahleneingabe einstellen lassen.

chaó

el cuervo

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