---

Hallo !

Kann mir jemand sagen wie ich aus Autocad 2000, zb. einem DXF-File
die Punkte die ich markiert habe oder ein gesamtes Koordinatenverzeichniss ausdrucken kann ?
geht das irgendwie ?

Hab mal was von einem Prog. gehört das dxf2koor hies ..
Wer kann mir helfen ?

ciao danke Martin

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

---

Hallo Martin,

bin mir nicht ganz sicher, aber schau mal da rein: http://www.cadwiesel.de

hope it helps

------------------
Gruss aus dem sonnigen Athen
Wolfgang

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

---

Hab so etwas in VBA programmiert, Nimmt Attribut des Blocks als ersten Wert der Spalte, dann Y-Wert und X-Wert. Textfile hat gleichen Namen und Pfad wie die Zeichnung

Code:

---

Option Explicit

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Koordinatenliste von Blöcken in Textdatei
' Auswahl von Blöcken
' Eingabe des Einsetzpunktes und -winkels der Liste
' Ergebnis: Liste mit Bezeichnung, X-Wert und Y-Wert
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

Public Sub Block_KoordListe_Text()

    Dim Absteck() As Absteckpunkt
    Dim AbsteckListe() As Absteckpunkt
    Dim AbsteckAnzahl As Long
    Dim Stelle As Long
   
    Dim I As Long
    Dim X As Long
   
    Dim SS As AcadSelectionSet
    Dim Blk As Object
    Dim BlkElem As AcadBlockReference
    Dim atts As Variant
    Dim AttsCount As Integer
   
    Dim pointUCS As Variant
    Dim pointWCS As Variant
   
    Dim FltTypes(0) As Integer
    Dim FltData(0) As Variant
   
    'Filter für Selectionset erstellen
    FltTypes(0) = 0: FltData(0) = "INSERT"
   
    ' Selectionset bilden und befüllen
    On Error Resume Next
        Set SS = ThisDrawing.SelectionSets("Block_KoordListe_TextAuswahl")
        If Err Then
            On Error GoTo 0
            Set SS = ThisDrawing.SelectionSets.Add("Block_KoordListe_TextAuswahl")
        Else
            On Error Resume Next
        End If
   
    SS.Clear
    ThisDrawing.Utility.Prompt "Blöcke auswählen"
    SS.SelectOnScreen FltTypes, FltData
   
    If SS.Count = 0 Then
        SS.Delete
        Exit Sub
    End If
   
    AbsteckAnzahl = SS.Count - 1
   
    ReDim Absteck(AbsteckAnzahl)
    ReDim AbsteckListe(AbsteckAnzahl)
   
    I = 0
    'Blockeigenschaften in Liste schreiben
    For Each Blk In SS
        Set BlkElem = Blk
        'Eingabe des Einsetzpunktes
        pointWCS = BlkElem.insertionPoint
        ' Translate the point into UCS coordinates
        pointUCS = ThisDrawing.Utility.TranslateCoordinates(pointWCS, acWorld, acUCS, False)
       
        atts = BlkElem.GetAttributes
        For AttsCount = 0 To UBound(atts)
            If atts(AttsCount).textString = "" Then
            Else
                Absteck(I).Bezeichnung = atts(AttsCount).textString
                Exit For
            End If
        Next AttsCount
       
        Absteck(I).XWert = Format(pointUCS(0), "0." & String(ThisDrawing.GetVariable("LUPREC"), "0"))
        Absteck(I).YWert = Format(pointUCS(1), "0." & String(ThisDrawing.GetVariable("LUPREC"), "0"))
       
        I = I + 1
    Next Blk
   
    'Liste sortieren
    For I = 0 To AbsteckAnzahl
        Stelle = 0
        For X = 0 To AbsteckAnzahl
            Select Case StrComp(Absteck(I).Bezeichnung, Absteck(X).Bezeichnung, 1)
                Case Is < 0
                Case Else
                    Stelle = Stelle + 1
            End Select
        Next X
        Stelle = Stelle - 1
        For X = Stelle To 0 Step -1
            If Absteck(I).Bezeichnung = AbsteckListe(X).Bezeichnung Then
            Else
                AbsteckListe(X) = Absteck(I)
                Exit For
            End If
        Next X
    Next I
   
    Dim BezLen As Long
    Dim XLen As Long
    Dim YLen As Long
   
    BezLen = Len("Bezeichnung")
    XLen = Len("Y-Wert")
    YLen = Len("X-Wert")
   
    'Ermitteln der Stellenanzahl
    For I = 0 To AbsteckAnzahl
        If BezLen < Len(AbsteckListe(I).Bezeichnung) Then BezLen = Len(AbsteckListe(I).Bezeichnung)
        If XLen < Len(AbsteckListe(I).XWert) Then XLen = Len(AbsteckListe(I).XWert)
        If YLen < Len(AbsteckListe(I).YWert) Then YLen = Len(AbsteckListe(I).YWert)
    Next I

    'Datei öffnen
    Dim TextObjekt, TextDatei
   
    Set TextObjekt = CreateObject("Scripting.FileSystemObject")
    On Error Resume Next
    Set TextDatei = TextObjekt.CreateTextFile(ThisDrawing.GetVariable("DWGPREFIX") & Left(ThisDrawing.GetVariable("DWGNAME"), Len(ThisDrawing.GetVariable("DWGNAME")) - 4) & ".txt", True)
    If Err Then Exit Sub
       
    TextDatei.WriteLine (String(1 + BezLen + 3 + XLen + 3 + YLen + 1, "-"))
    TextDatei.WriteLine (funTextLVN("Bezeichnung", BezLen, 1, 0) & funTextLVN("Y-Wert", XLen, 3, 0) & funTextLVN("X-Wert", YLen, 3, 1))
    TextDatei.WriteLine (String(1 + BezLen + 3 + XLen + 3 + YLen + 1, "-"))
   
    For I = 0 To AbsteckAnzahl
        TextDatei.WriteLine (funTextLVN(AbsteckListe(I).Bezeichnung, BezLen, 1, 0) _
                          & funTextLVN(funPunkt(AbsteckListe(I).XWert), XLen, 3, 0) _
                          & funTextLVN(funPunkt(AbsteckListe(I).YWert), YLen, 3, 1))
    Next I
   
    TextDatei.WriteLine (String(1 + BezLen + 3 + XLen + 3 + YLen + 1, "-"))
       
    TextDatei.Close
    Set TextObjekt = Nothing
   
    SS.Delete


End Sub

' Stellt Text Leerstellen voran und hintenan:
' 1. Verlängert den Text auf "GesLaenge" indem Anhang vorgestellt werden
' 2. Stellt Anhang mit Wert "Vor" vor den Text
' 3. Stellt Anhang mit Wert "Nach" nach den Text
Public Function funTextLVN(Text As String, GesLaenge As Long, Vor As Long, Nach As Long, Optional Anhang As String = " ")
   
    Dim GLPlus As String        ' Anzahl der Leerzeichen für Gesamtlänge
   
    GLPlus = GesLaenge - Len(Text)
    Text = String(GLPlus + Vor, Anhang) & Text & String(Nach, Anhang)
   
    funTextLVN = Text

End Function

---

------------------
Roland

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

---

das gleiche für Punkte, unsortiert.

Code:

---

Option Explicit

' Übergibt Punktekoordinaten in Textdatei und
' speichert in Zeichnungspfad und Zeichnungsnamen
Public Sub Dots_Extract_Text()
    Dim SS As AcadSelectionSet
    Dim Filnum As Integer
    Dim atts As Variant
    Dim obj As Object
    Dim Punkt As AcadPoint
    Dim PT(0 To 2) As String
    Dim Pfad As String
    Dim DatName As String
    Dim PfadDatei As String
    Dim FltTypes(0) As Integer
    Dim FltData(0) As Variant
    Dim pointUCS As Variant
    Dim pointWCS As Variant
   
    ' Filter erstellen
    FltTypes(0) = 0: FltData(0) = "POINT"
   
    ' Selectionset bilden und befüllen
    On Error Resume Next
        Set SS = ThisDrawing.SelectionSets("aussi_dotAuswahl")
        If Err Then
            On Error GoTo 0
            Set SS = ThisDrawing.SelectionSets.Add("aussi_dotAuswahl")
        Else
            On Error Resume Next
        End If
   
    SS.Clear
    SS.SelectOnScreen FltTypes, FltData
   
    Pfad = ThisDrawing.GetVariable("DWGPREFIX")
    DatName = ThisDrawing.GetVariable("DWGNAME")
    DatName = Left(DatName, Len(DatName) - 4)
    PfadDatei = Pfad & DatName & ".txt"
   
    'Datei öffnen
    Dim fs, a
   
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set a = fs.CreateTextFile(PfadDatei, True)
   
    a.WriteLine ("X-Wert;Y-Wert;Z-Wert")
    ' Inhalt der Elemente schreiben
    For Each obj In SS
        Set Punkt = obj
        'Eingabe des Einsetzpunktes
        pointWCS = Punkt.Coordinates
        ' Translate the point into UCS coordinates
        pointUCS = ThisDrawing.Utility.TranslateCoordinates(pointWCS, acWorld, acUCS, False)
       
        PT(0) = funPunkt(LTrim(Str(pointUCS(0))))
        PT(1) = funPunkt(LTrim(Str(pointUCS(1))))
        PT(2) = funPunkt(LTrim(Str(pointUCS(2))))
        a.WriteLine (PT(0) & ";" & PT(1) & ";" & PT(2))
    Next obj
       
    a.Close
End Sub

---

------------------
Roland

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

---

das ganze noch einmal für Punkte in Excel-Datei

Code:

---

Option Explicit

Public ExcelVBA As Excel.Application    ' stellt Excel für alle Prozeduren bereit

' Übergibt Punktekoordinaten in Exeldatenblatt und
' speichert in Zeichnungspfand und Zeichnungsnamen
Public Sub Dots_Extract_Excel()
   
    Dim ExcelSheet As Object
    Dim ExcelWorkbook As Object
   
    Dim RowNum As Integer
    Dim Count As Integer
   
    Dim Pfad As String
    Dim DatName As String
    Dim PfadDatei As String
   
    Dim SS As AcadSelectionSet
    Dim Punkt As Object
    Dim PunktElem As AcadPoint
   
    Dim pointUCS As Variant
    Dim pointWCS As Variant
   
    Dim FltTypes(0) As Integer
    Dim FltData(0) As Variant
   
   
   
    'Filter für Selectionset erstellen
    FltTypes(0) = 0: FltData(0) = "POINT"
   
    ' Selectionset bilden und befüllen
    On Error Resume Next
        Set SS = ThisDrawing.SelectionSets("Dots_Extract_ExcelAuswahl")
        If Err Then
            On Error GoTo 0
            Set SS = ThisDrawing.SelectionSets.Add("Dots_Extract_ExcelAuswahl")
        Else
            On Error Resume Next
        End If
   
    SS.Clear
    SS.SelectOnScreen FltTypes, FltData
   
    If SS.Count = 0 Then
        SS.Delete
        Exit Sub
    End If
   
    ' Pfad für Speicherung Datei ermitteln
    Pfad = ThisDrawing.GetVariable("DWGPREFIX")
    DatName = ThisDrawing.GetVariable("DWGNAME")
    DatName = Left(DatName, Len(DatName) - 4)
    PfadDatei = Pfad & DatName & ".xls"
   
    ' Excel starten.
    If ExcelVBA Is Nothing Then Set ExcelVBA = New Excel.Application
    ExcelVBA.Visible = True
   
    ' Erstellen einer neuen Arbeitsmappe und Suchen des aktiven Arbeitsblatts.
    Set ExcelWorkbook = ExcelVBA.Workbooks.Add
    Set ExcelSheet = ExcelVBA.ActiveSheet
    ExcelWorkbook.SaveAs PfadDatei
   
    RowNum = 1
   
    ExcelSheet.Cells(RowNum, 1).value = "X"
    ExcelSheet.Cells(RowNum, 2).value = "Y"
    ExcelSheet.Cells(RowNum, 3).value = "Z"
   
    ' Modellbereich durchlaufen, umalle Blockreferenzen zu finden.
    For Each Punkt In SS
        Set PunktElem = Punkt
        'Eingabe des Einsetzpunktes
        pointWCS = PunktElem.Coordinates
        ' Translate the point into UCS coordinates
        pointUCS = ThisDrawing.Utility.TranslateCoordinates(pointWCS, acWorld, acUCS, False)
       
        ' X-, Y-, Z-Werte der Punkte in Excel kopieren
        RowNum = RowNum + 1
        For Count = 1 To 3
            ExcelSheet.Cells(RowNum, Count).value = pointUCS(Count - 1)
        Next Count
    Next Punkt
    ExcelVBA.WindowState = xlMinimized
End Sub

---

------------------
Roland

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

---

Etwas habe ich vergessen, bei den Funktionen für die Punkte werden auch die Z-Werte übergeben.

------------------
Roland

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

---

Also das hilf mir 100 %ig danke schon mal !

ciao martin

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