---

Hallo zusammen

Ich möchte einen Block als Blockdatei exportieren.
Wie stelle ich das an?

------------------
Gruss Kai

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

---

es gibt die funktion thisdrawing.wblock,
leider funktioniert diese nur mit einem selectionset, also direkt aus der blockdefinition heraus, geht meines wissens leider nicht

du musst den block in die zeichnung einfügen, dann ursprungen, die beim ursprung erzeugten elemente in ein selectionset packen, und mit wblock abspeichern

danach kannst du die elemente wieder löschen

------------------
***********************************************
AutoCad 2000i, 2002, 2004 deutsch und englisch
Windows 2000, NT, XP

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

---

Da gabs schon mal was mit Blöcke expotieren. Währe da nicht ein anknüpfpunkt dabei? http://ww3.cad.de/foren/ubb/Forum54/HTML/002342.shtml

------------------
Gruss
Caladia

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

---

Du müsstest eigentlich nur die Elemente des Blocks (nicht der Referenz) in ein SelSet geben und dann als WBlock rausspeichern. Sollte eigentlich kein Porblem sein. Schau ich mir einmal an.

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

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

---

Probier es einmal damit

Code:

---

Public Sub BlöckeAusZeichnung4()
   
    Dim Blöcke As AcadBlocks
    Dim BlObj As AcadBlock
   
    Dim ss As AcadSelectionSet
   
    Dim objEnt As AcadEntity
    Dim objArray() As AcadEntity
    Dim intcnt As Integer
    Dim varTemp As Variant
    Dim Name As String
    Dim Path As String
   
    Dim ActiveDoc As AcadDocument
   
    Set ActiveDoc = Application.ActiveDocument
   
   
    Set Blöcke = ActiveDoc.Blocks
    If Blöcke.Count = 0 Then Exit Sub
   
    Set ss = CreateSelectionSet("Blöcke")
   
    For Each BlObj In Blöcke
        If Not (BlObj.IsLayout Or BlObj.IsXRef) Then
            Name = BlObj.Name
            If InStr(Name, "*") > 0 Or BlObj.Count = 0 Then GoTo NextObj
            'If BlObj.Count = 0 Then GoTo NextObj
           
            Path = "D:/_Buero/Zeichnungen/_Test/" & Name & ".dwg"
            intcnt = 0
            ReDim objArray(BlObj.Count - 1)
            For Each objEnt In BlObj
                Set objArray(intcnt) = objEnt
                intcnt = intcnt + 1
            Next objEnt
            Dim objSpace As AcadBlock
            Set objSpace = ThisDrawing.CurrentSpace
            varTemp = ActiveDoc.CopyObjects(objArray, objSpace)
            ss.AddItems varTemp
           
            ActiveDoc.Wblock Path, ss
            ss.Erase
        End If
NextObj:
    Next BlObj
ENDE:
    ss.Delete

End Sub

---

Die Funktion CurrentSpace gehört in ThisDrawing

Code:

---

Public Property Get CurrentSpace() As AcadBlock
    If Me.ActiveSpace = acModelSpace Then
        Set CurrentSpace = Me.ModelSpace
    Else
        If Me.MSpace Then
            Set CurrentSpace = Me.ModelSpace
        Else
            Set CurrentSpace = Me.ActiveLayout.Block
        End If
    End If
End Property

---

Natürlich mußt du den Pfad auch noch ändern. Vorsicht!!! Bereits bestehende Dateien werden ohne Vorwarnung überschrieben.

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

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

---

Hier eine kleine Variant

Code:

---

'Schreibt alle Blöcke mit Vorschau aus der Zeichnung
Public Sub BlöckeAusZeichnung5()
   
    Dim Blöcke As AcadBlocks
    Dim BlObj As AcadBlock
   
    Dim ss As AcadSelectionSet
   
    Dim objEnt As AcadEntity
    Dim objArray() As AcadEntity
    Dim intcnt As Integer
    Dim Name As String
    Dim Path As String
   
    Dim ActiveDoc As AcadDocument
    Dim BlockDoc As AcadDocument
    Dim objSpace As AcadBlock
   
    Set ActiveDoc = Application.ActiveDocument
   
   
    Set Blöcke = ActiveDoc.Blocks
    If Blöcke.Count = 0 Then Exit Sub
   
    Set ss = CreateSelectionSet("Blöcke")
   
    For Each BlObj In Blöcke
        If Not (BlObj.IsLayout Or BlObj.IsXRef) Then
            Name = BlObj.Name
            If InStr(Name, "*") > 0 Or BlObj.Count = 0 Then GoTo NextObj
           
            Path = "D:/_Buero/Zeichnungen/_Test/" & Name & ".dwg"
            intcnt = 0
            ReDim objArray(BlObj.Count - 1)
            For Each objEnt In BlObj
                Set objArray(intcnt) = objEnt
                intcnt = intcnt + 1
            Next objEnt
            Set BlockDoc = Documents.Add("Pauser_MM1")
           
            On Error Resume Next
            ActiveDoc.CopyObjects objArray, BlockDoc.ModelSpace
            If Err Then
                MsgBox Name & " kann nicht gespeichert werden"
                Set BlockDoc = Nothing
           
            Else
                BlockDoc.Activate
                ZoomExtents
                BlockDoc.SaveAs Path
                BlockDoc.Close
            End If
           
        End If
NextObj:
    Next BlObj
ENDE:
    ss.Delete

End Sub

---

Vorsicht!!! Die Vorlagendatei "Pauser_MM1" gehört an eure Bedürfnisse angepasst.

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

[Diese Nachricht wurde von RoSiNiNo am 18. Nov. 2003 editiert.]

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