Hot News:

Unser Angebot:

  Foren auf CAD.de (alle Foren)
  AutoCAD VBA
  Block austauschen

Antwort erstellen  Neues Thema erstellen
CAD.de Login | Logout | Profil | Profil bearbeiten | Registrieren | Voreinstellungen | Hilfe | Suchen

Anzeige:

Darstellung des Themas zum Ausdrucken. Bitte dann die Druckfunktion des Browsers verwenden. | Suche nach Beiträgen nächster neuer Beitrag | nächster älterer Beitrag
  
Gut zu wissen: Hilfreiche Tipps und Tricks aus der Praxis prägnant, und auf den Punkt gebracht für Autodesk Produkte
Autor Thema:  Block austauschen (2256 mal gelesen)
zech
Mitglied



Sehen Sie sich das Profil von zech an!   Senden Sie eine Private Message an zech  Schreiben Sie einen Gästebucheintrag für zech

Beiträge: 89
Registriert: 09.11.2004

Autocad Architecture 2016
Civil3D 2016
Microstation
EliteCAD

erstellt am: 10. Mrz. 2016 12:38    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities

Hallo,
ich möchte gern einen vorhandenen Block in einer Zeichnung mit VBA austauschen, mit "-einfüge" .....
Die grafische Ausprägung soll sich ändern.
In Lisp ist das kein Problem, nach der Frage "neu definieren" die mit "J" beantwortet wird folgt einfach ein ^C.
In VBA Autocad 2016 geht das nicht, jedenfalls bei mir nicht. Habe schon viel probiert, aber
es klappt einfach nicht.
ThisDrawing.SendCommand "-einfüge" & vbCr & "altblock=neublock" & vbCr & "J" & vbCr & ......... (hier fehlt etwas)

Ich denke mal in VBA geht das nicht mehr, da Autodesk ja auf .NET setzt. Damit kann ich mich aber noch nicht so richtig anfreunden,
da die Programmierung wesentlich komplexer ist und ein einfaches "debuggen" wie in VBA oder Lisp ist auch nicht möglich.

Oder gibt es in vba eine andere Möglichkeit als "Sendcommand"?

Vielen Dank im voraus


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

KlaK
Ehrenmitglied V.I.P. h.c.
Dipl. Ing. Vermessung, CAD- und Netz-Admin



Sehen Sie sich das Profil von KlaK an!   Senden Sie eine Private Message an KlaK  Schreiben Sie einen Gästebucheintrag für KlaK

Beiträge: 2624
Registriert: 02.05.2006

AutoCAD LandDesktop R2 bis 2004
Civil 3D 2005 - 2022
Plateia, Canalis
Visual Basic

erstellt am: 10. Mrz. 2016 19:59    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities Nur für zech 10 Unities + Antwort hilfreich

Hallo Zech,

Keine Ahnung warum Du das mit SendCommand lösen möchtest, im Prinzip mußt Du ja nur den Block als BlockRef neu laden:

Code:

    Dim blockRefObj As AcadBlockReference
    Dim sBlock As String
    insertionPnt(0) = 5#: insertionPnt(1) = 5#: insertionPnt(2) = 0
    sBlock = "D:\Forum\CAD.de\VBA\Kreis\CircleBlock.dwg"
    Set blockRefObj = ThisDrawing.ModelSpace.InsertBlock(insertionPnt, sBlock, 1#, 1#, 1#, 0)
    blockRefObj.Delete

Es erfolgt dann automatisch ein Austauschen der Blockdefinition und der bestehenden Blockreferenzen.

Grüße
Klaus  

[Edit]Vielleicht noch zur Ergänzung:
Die zu ladende Zeichnung sollte die neue Blockdefinition enthalten und der Name der DWG ist der Name des auszutauschenden Blockes. Damit das ganze sichtbar wird muß natürlich ein Regenerieren durchgeführt werden.
Andere Möglichkeit wäre eine interne Neudefinition des Blockes, d.h. Du nimmst die Blockdefinition und löscht alle Item, dann den neuen Block, fügst eine referenz ein und explodest diese. Die Explode-Liste kann dann als neue Definition dem alten Block zugeordnet. Aber da geht es schneller den neuen Block als Zeichnung mit altem Namen rauszuschreiben und wieder einzulesen.

[Diese Nachricht wurde von KlaK am 10. Mrz. 2016 editiert.]

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

zech
Mitglied



Sehen Sie sich das Profil von zech an!   Senden Sie eine Private Message an zech  Schreiben Sie einen Gästebucheintrag für zech

Beiträge: 89
Registriert: 09.11.2004

Autocad Architecture 2016
Civil3D 2016
Microstation
EliteCAD

erstellt am: 11. Mrz. 2016 06:35    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities


Meldung.jpg


Uberwachung.jpg

 
Hallo KlaK,
danke für die Antwort. Eigentlich wollte ich ja den Block in der Zeichnung mit dem Namen "9500" neu definieren mit einem Block auf der Festplatte mit dem Namen "9500Alkis". Dies geht ja mit dieser Lösung nicht. Also habe ich den Block auf der Festplatte ebenfalls "9500" genannt, nicht unbedingt schön, aber wenn's geht.

Leider bekomme ich mit dem Programmcode einen Fehler in der "Set blockRefObj - Zeile). Siehe beigelegte Datei (Grafikdump)

Grüße aus Berlin

Bei der Überwachung sieht etwas sehr komisch aus, Fehler in VBA?

[Diese Nachricht wurde von zech am 11. Mrz. 2016 editiert.]

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

KlaK
Ehrenmitglied V.I.P. h.c.
Dipl. Ing. Vermessung, CAD- und Netz-Admin



Sehen Sie sich das Profil von KlaK an!   Senden Sie eine Private Message an KlaK  Schreiben Sie einen Gästebucheintrag für KlaK

Beiträge: 2624
Registriert: 02.05.2006

AutoCAD LandDesktop R2 bis 2004
Civil 3D 2005 - 2022
Plateia, Canalis
Visual Basic

erstellt am: 11. Mrz. 2016 10:15    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities Nur für zech 10 Unities + Antwort hilfreich

Hey,

was passiert wenn Du anstelle Slash(/) den Backslash (\) beim Pfad verwendest ?

Ansonsten habe ich nur 2014 zur Verfügung, keine Ahnung ob die da in 2016 etwas geändert haben ...

Grüße
Klaus 

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

zech
Mitglied



Sehen Sie sich das Profil von zech an!   Senden Sie eine Private Message an zech  Schreiben Sie einen Gästebucheintrag für zech

Beiträge: 89
Registriert: 09.11.2004

Autocad Architecture 2016
Civil3D 2016
Microstation
EliteCAD

erstellt am: 11. Mrz. 2016 10:24    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities

Hallo KLaK,
Backslash ist unzulässig, Slash ist schon korrekt.
Wahrscheinlich ist was geändert, ich habe auch anderweitige Schwierigkeiten mit 2016 und VBA wenn auf einem Rechner Architecture und Civil 3D installiert sind.

Trotzdem ...
Vielen Dank und ein schönes Wochenende

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

KlaK
Ehrenmitglied V.I.P. h.c.
Dipl. Ing. Vermessung, CAD- und Netz-Admin



Sehen Sie sich das Profil von KlaK an!   Senden Sie eine Private Message an KlaK  Schreiben Sie einen Gästebucheintrag für KlaK

Beiträge: 2624
Registriert: 02.05.2006

AutoCAD LandDesktop R2 bis 2004
Civil 3D 2005 - 2022
Plateia, Canalis
Visual Basic

erstellt am: 11. Mrz. 2016 15:21    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities Nur für zech 10 Unities + Antwort hilfreich

Letzter Versuch (mit SendCommand):
Code:

    Dim sBlock As String
    Dim sCmd As String

    sBlock = "9500=M:\Acad\Archi-2016\Standard-2016\Symbole\9500Alkis.dwg" ' AlterBlockname=Neudefinition
    sCmd = "-einfüge" & vbCr & sBlock & vbCr & "J" & vbCr & Chr(27)    ' nur den Block neu definieren
    ThisDrawing.SendCommand sCmd



Damit wird nur der Block neu definiert. Anstelle des ESC ( Chr(27) ), könnte man auch die Koordinaten gefolgt von Skalierung X und Y und Drehwinkel angeben, für reine Neudefinition aber nicht erforderlich.

Schönes WE
Klaus    

[Diese Nachricht wurde von KlaK am 12. Mrz. 2016 editiert.]

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

KlaK
Ehrenmitglied V.I.P. h.c.
Dipl. Ing. Vermessung, CAD- und Netz-Admin



Sehen Sie sich das Profil von KlaK an!   Senden Sie eine Private Message an KlaK  Schreiben Sie einen Gästebucheintrag für KlaK

Beiträge: 2624
Registriert: 02.05.2006

AutoCAD LandDesktop R2 bis 2004
Civil 3D 2005 - 2022
Plateia, Canalis
Visual Basic

erstellt am: 12. Mrz. 2016 12:57    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities Nur für zech 10 Unities + Antwort hilfreich

Zitat:
Original erstellt von zech:
Hallo KLaK,
Backslash ist unzulässig, Slash ist schon korrekt.
Wahrscheinlich ist was geändert, ich habe auch anderweitige Schwierigkeiten mit 2016 und VBA wenn auf einem Rechner Architecture und Civil 3D installiert sind.

Trotzdem ...
Vielen Dank und ein schönes Wochenende



Habe Interessehalber noch einmal nach den Laufzeitfehler gesucht.
Die Ergebnisse deuten alle auf ein Netzwerkproblem (evtl. Zugriffsrechte) hin.
Vielleicht kannst Du das einfach mal lokal testen.

Außerdem habe ich keinen Hinweis gefunden warum hier unbedingt der Slash (/) verwendet werden muß. Hast Du denn das richtige VBA zur Version 2016 installiert? 64 Bit? Einmal die Type-Libraries überprüft (Verweise)?

Habt Ihr denn einen Unix-Server auf den Du zugreifst? Das wäre für mich die einzig logische Erklärung.
Welche Fehlermeldung kommt wenn Du den Backslash verwendest?
Aber vielleicht bist Du es einfach nur so von Lisp gewöhnt. Dort wird meist der slash "/" als Verzeichnistrenner verwendet, den Backslash müßte man doppelt angeben also "\\" damit er richtig erkannt wird.

Der Screenshot "Überwachung.jpg" wurde nach der Fehlermeldung gemacht, vor der Fehlermeldung müßte der Variablenname richtig dargestellt sein. Grund ist dass Autocad hier den Variablennamen verändert. Wenn die Aufteilung (Pfad/Name) richtig durchgeführt wäre müßte der Variablenwert so aussehen:
"9500  d/Archi-2016/Standard-2016/Symbole/9500.dwg"
der Blockname wird extrahiert und an den Anfang (mit nicht sichtbaren Abschlußbit) gesetzt

Eine andere Fehlerquelle wäre noch wenn der Block 9500 in der Zeichnung nicht existiert, dann ist ein umdefinieren natürlich nicht möglich und es kommt auch der Laufzeitfehler 80200014. Wie oben schon erläutert stimmt hier die Umsetzung des Blocknames nicht, Autocad bzw. VBA erwartet hier für den Pfadnamen den Backslash!

Welches Office hast Du installiert? 32 oder 64 Bit? Hatte da mal Probleme mit einem 32 Bit Office 2010, seitdem ich das 64 Bit installiert habe klappen auch die alten VBA-Programme wieder.

[Diese Nachricht wurde von KlaK am 13. Mrz. 2016 editiert.]

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

zech
Mitglied



Sehen Sie sich das Profil von zech an!   Senden Sie eine Private Message an zech  Schreiben Sie einen Gästebucheintrag für zech

Beiträge: 89
Registriert: 09.11.2004

Autocad Architecture 2016
Civil3D 2016
Microstation
EliteCAD

erstellt am: 14. Mrz. 2016 07:36    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities


chr27.jpg

 
Hallo KLaK,
danke für die erschöpfende Antwort. chr(27) läuft auf einen Fehler raus, siehe angehängte Datei. Mit dem Slash und Backslash habe ich mich geirrt. Es ist beides zulässig. Ich habe es mit beiden probiert und es wird nicht beanstandet. Da der "Abbruch" nicht funktioniert habe ich deine Idee aufgegriffen das Symbol mit "SendCommand" an der Position 0,0 eingefügt anstatt abzubrechen und dann das Symbol gelöscht. Viola, die Blöcke sind getauscht.
Office ist bei uns überall die 32bit Version installiert, da damals als ich es installiert habe, noch von der 64bit Version abgeraten wurde, jedenfalls ergaben das die Rechergen im Internet.

Dieses Problem ist jedenfalls erstmal gelöst, ich hoffe dass es nicht noch mehr unliebsame Überraschungen gibt.

Vielen Dank dafür aus Berlin

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

rexxitall
Mitglied
Dipl. -Ing. Bau


Sehen Sie sich das Profil von rexxitall an!   Senden Sie eine Private Message an rexxitall  Schreiben Sie einen Gästebucheintrag für rexxitall

Beiträge: 266
Registriert: 07.06.2013

Various: systems, Operating systems, cad systems, cad versions, programming languages.

erstellt am: 17. Mrz. 2016 23:20    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities Nur für zech 10 Unities + Antwort hilfreich

Hi,

Ich würde den alten Block umbenennen und dann die neue Blockdefinition "irgendwie" einlesen.
Sprich als DWG oder aus einer anderen Zeichnung einkopieren.
Nun kann man die Propertys, Attribute, Parameter gemütlich auslesen und temporär in z.B einem Scripting dictionary speichern.
Nun fügt man den neuen Block ein und setzt die gerade gespeicherten Eigenschaften. SObald man mit allen Blöckebn fertig ist, können die alten umbenannten gelöscht werden. Als auch denen Block Definition
Das klappt gefahrlos mit allen Blocktypen. Hintenrum an den definitionen rumzufummeln halte ich für keine gute Idee.
Gerade wenn man viel Atribute hat oder Parameter müssen die dann neu generiert werden bzw mit Attsync angepasst werden. Spätestens da ist das Neueinfügen Welten schneller.

Sub BLOCK_CLONE_REPLACE(ByVal selectionsetobject, opt)
    Dim BNAME As String
    Dim P(2) As Double
    Dim ANGLE As Double
    Dim entity As AcadEntity
    Dim blockref As AcadBlockReference
    Dim blockref2 As AcadBlockReference
    Dim PIAPDICT As New Scripting.DICTIONARY
    Dim distance As Variant
    Dim PositionX As Variant
    Dim Positiony As Variant

    Dim source As AcadBlockReference
    Dim dest As AcadBlockReference
    Dim N As Long

    Dim PARA As New Scripting.DICTIONARY
    Dim PROP As New Scripting.DICTIONARY
    Dim attr As New Scripting.DICTIONARY
    Application.UPDATE

    Call layer_clone("TMP", "0")
    sBlockName = InputBox("BLOCK NAME NEW", "BLOCK NEW", "")

    If sBlockName = "" Then Exit Sub

    Dim REPPROP As Boolean
    Dim REPATTR As Boolean
    Dim REPPARA As Boolean

    REPPROP = SLOPEFORM.REPPROP
    REPATTR = SLOPEFORM.REPATTR
    REPPARA = SLOPEFORM.REPPARA


    Dim all As Boolean
    all = True
    For Each entity In selectionsetobject

        If LCase(entity.ObjectName) = "acdbblockreference" Then

            err.Clear

            Set source = entity
            If REPPROP Then Call block_PROPERTYS_to_dictionary(source, PROP)
            If REPATTR Then Call block_ATTRIBUTE_to_dictionary(source, attr)
            If REPPARA Then Call block_PARAMETER_to_dictionary(source, PARA, all)

            P(0) = source.InsertionPoint(0)
            P(1) = source.InsertionPoint(1)
            P(2) = source.InsertionPoint(2)


            Set dest = block_insert(P, sBlockName, source.XScaleFactor, source.XScaleFactor, source.ZScaleFactor, source.Rotation)


            If REPPROP Then Call block_PROPERTYS_from_dictionary(dest, PROP)
            If REPATTR Then Call block_ATTRIBUTE_from_dictionary(dest, attr)
            If REPPARA Then Call block_PARAMETER_from_dictionary(dest, PARA, all)

            dwgunits = S2D(ThisDrawing.GetVariable("INSUNITS"))
            bu = dest.InsUnits
            If bu <> dwgunits Then
                Dim SC As Double
                If dwgunits = 6 And bu = "Millimeter" Then SC = 0.001    'dwg meter, blo mm
                If dwgunits = 4 And bu = "Meter" Then SC = 1000    'dwg mm ,blo meter

                If SC <> 0 Then
               
                dest.ScaleEntity dest.InsertionPoint, SC
               
                End If
            End If


            PARA.RemoveAll
            PROP.RemoveAll
            attr.RemoveAll
            If err.Number = 0 Then
Dim LAYER As AcadLayer
Set LAYER = ThisDrawing.layers(source.LAYER)
LAYER.Lock = False


source.LAYER = "TMP"
            End If

            N = N + 1
        End If
    Next


End Sub


Function block_ATTRIBUTE_from_dictionary(entity As AcadEntity, dict As Scripting.DICTIONARY) As Boolean
    Dim blo As AcadBlockReference
    On Error Resume Next
    If LCase(entity.ObjectName) <> "acdbblockreference" Then
        On Error GoTo 0
        Exit Function
    End If
    Set blo = entity
    Dim ATTLIST As Variant
    err.Clear
    block_ATTRIBUTE_from_dictionary = True
    Dim tagname As String
    Dim tagvalue As String
    Dim tagprompt As String
    Dim tagpreset As String
    Dim attrib As Object    'AcadAttribute
    Dim dict_tagname As String

    On Error Resume Next
    'If blo Is Nothing Then Exit Function
    If blo.HasAttributes Then
        ATTLIST = blo.GetAttributes
        For i = LBound(ATTLIST) To UBound(ATTLIST)
            'Set attrib = attlist(i)
            tagname = Trim(ATTLIST(i).TAGSTRING)
            If InStr(tagname, "__") = 0 Then
                tagvalue = ATTLIST(i).TEXTSTRING
                '            tagprompt = attlist(i).PromptString
                '          tagpreset = attrib.Preset
                If Right(tagname, 4) = "_001" Then tagname = Left(tagname, Len(tagname) - 4)
                dict_tagname = "ATTR_" & tagname
                If dict.Exists(dict_tagname) Then ATTLIST(i).TEXTSTRING = dict.ITEM(dict_tagname)
                If err.Number <> 0 Then bblock_attribute_from_dictionary = False
            End If
        Next
    End If
    If err.Number <> 0 Then block_ATTRIBUTE_from_dictionary = False
End Function

Function block_ATTRIBUTE_to_dictionary(entity As AcadEntity, dict As Scripting.DICTIONARY) As Boolean

    Dim blo As AcadBlockReference
    If LCase(entity.ObjectName) <> "acdbblockreference" Then Exit Function
    Set blo = entity
    Dim ATTLIST As Variant
    err.Clear
    block_ATTRIBUTE_to_dictionary = True
    Dim tagname As String
    Dim tagvalue As String
    Dim tagprompt As String
    Dim tagpreset As String
    Dim attrib As AcadAttribute
    Dim dict_tagname As String

    On Error Resume Next
    'If blo Is Nothing Then Exit Function
    If blo.HasAttributes Then
        ATTLIST = blo.GetAttributes
        For i = LBound(ATTLIST) To UBound(ATTLIST)
            ' attrib = attlist(i)
            tagname = Trim(ATTLIST(i).TAGSTRING)
            tagvalue = Trim(ATTLIST(i).TEXTSTRING)
            '            On Error Resume Next
            '            tagprompt = Trim(attrib.PromptString)
            '            tagpreset = Trim(attrib.Preset)
            '            On Error GoTo 0
            If Right(tagname, 4) = "_001" Then tagname = Left(tagname, Len(tagname) - 4)
            dict_tagname = "ATTR_" & tagname
            If UCase(tagname) = tagname Then
                If dict.Exists(dict_tagname) Then
                    dict.ITEM(dict_tagname) = Trim(tagvalue)
                Else
                    dict.Add dict_tagname, tagvalue
                End If
            End If
            If err.Number <> 0 Then block_ATTRIBUTE_to_dictionary = False
        Next
    End If

    If err.Number <> 0 Then block_ATTRIBUTE_to_dictionary = False

End Function
Function block_PARAMETER_from_dictionary(entity As AcadEntity, dict As Scripting.DICTIONARY, Optional all As Boolean = False, Optional roundthem As Long = -1) As Boolean

    Dim blockref As AcadBlockReference
    On Error Resume Next
    If LCase(entity.ObjectName) <> "acdbblockreference" Then
        On Error GoTo 0
        Exit Function
    End If

    Set blockref = entity
    err.Clear
    block_PARAMETER_from_dictionary = True

    Dim DynProp As AcadDynamicBlockReferenceProperty
    Dim Variable As Variant
    Dim V As Variant
    Dim proptagname As String
    Dim proptagvalue As String
    Dim proptagunits As String
    Dim proptagdescription As String

    Dim k As Long
    Dim VT As typeofVar


    If Not blockref.IsDynamicBlock Then Exit Function
    Variable = blockref.GetDynamicBlockProperties

    For k = LBound(Variable) To UBound(Variable)
        Set DynProp = Variable(k)


        proptagname = Trim(DynProp.propertyName)
        If all = False Then proptagname = UCase(proptagname)

        If DynProp.propertyName = proptagname Then
            proptagunits = DynProp.UnitsType
            proptagdescription = DynProp.DESCRIPTION

            V = DynProp.Value

            dict_tagname = "PARA_" & proptagname
            If dict.Exists(dict_tagname) Then
                dictvalue = dict.ITEM(dict_tagname)


                If roundthem > -1 Then
                    dictvalue = REPLACE(dictvalue, ",", ".")
                    If IsNumeric(dictvalue) = True Then
                        Value = val(dictvalue)
                        Value = round(Value, Abs(roundthem))
                        dictvalue = Trim(str(Value))
                    End If
                End If


                'Debug.Print proptagname, , proptagvalue, vartype(V)


                Select Case VarType(V)

                Case vbEmpty    '0
                    V = ""
                Case vbNull  '1
                    V = ""
                    '            Case vbInteger    '2
                    '                tagvalue = Trim(str(V))
                    '            Case vbLong    '3
                    '                tagvalue = Trim(str(V))
                    '            Case vbSingle    '4
                    '                tagvalue = Trim(str(V))
                    '            Case vbDouble  '5
                    '                tagvalue = Trim(str(V))
                    '            Case vbCurrency  '6
                    '                tagvalue = Trim(str(V))
                Case vbDate  '7
                    V = Trim(dictvalue)
                Case vbString  '8
                    V = Trim(dictvalue)
                Case vbObject    '9
                    V = ""
                Case vbError    '10
                    V = ""
                Case vbBoolean    '11
                    If V = "TRUE" Then V = True Else V = False
                Case vbVariant    '12
                    V = ""
                Case vbDataObject    '13
                    V = ""
                    '            Case vbDecimal    '14
                    '                tagvalue = Trim(str(V))
                    '            Case vbByte    '15
                    '                tagvalue = Trim(str(V))
                Case Else
                    V = val(dictvalue)
                End Select
                On Error Resume Next
                DynProp.Value = V

                If err.Number <> 0 Then block_PARAMETER_from_dictionary = False
            End If

        End If
    Next


End Function

Function block_PARAMETER_to_dictionary(entity As AcadEntity, dict As Scripting.DICTIONARY, Optional all As Boolean = False) As Boolean
    Dim blockref As AcadBlockReference
    If LCase(entity.ObjectName) <> "acdbblockreference" Then Exit Function
    Set blockref = entity
    If dict Is Nothing Then Exit Function
    err.Clear
    block_PARAMETER_to_dictionary = True

    Dim DynProp As AcadDynamicBlockReferenceProperty
    Dim Variable As Variant
    Dim V As Variant
    Dim proptagname As String
    Dim proptagvalue As String
    Dim proptagunits As String
    Dim proptagdescription As String

    Dim k As Long
    Dim VT As typeofVar


    If Not blockref.IsDynamicBlock Then Exit Function
    Variable = blockref.GetDynamicBlockProperties

    For k = LBound(Variable) To UBound(Variable)
        Set DynProp = Variable(k)
        proptagname = Trim(DynProp.propertyName)
        If all = False Then proptagname = UCase(proptagname)


        If DynProp.propertyName = proptagname Then
            proptagunits = DynProp.UnitsType
            proptagdescription = DynProp.DESCRIPTION

            V = DynProp.Value

            dict_tagname = "PARA_" & proptagname

            Debug.Print proptagname, , proptagvalue, VarType(V)


            Select Case VarType(V)

            Case vbEmpty    '0
                tagvalue = ""
            Case vbNull  '1
                tagvalue = ""
                '            Case vbInteger    '2
                '                tagvalue = Trim(str(V))
                '            Case vbLong    '3
                '                tagvalue = Trim(str(V))
                '            Case vbSingle    '4
                '                tagvalue = Trim(str(V))
                '            Case vbDouble  '5
                '                tagvalue = Trim(str(V))
                '            Case vbCurrency  '6
                '                tagvalue = Trim(str(V))
            Case vbDate  '7
                tagvalue = Trim(V)
            Case vbString  '8
                tagvalue = Trim(V)
            Case vbObject    '9
                tagvalue = ""
            Case vbError    '10
                tagvalue = ""
            Case vbBoolean    '11
                If V Then tagvalue = "TRUE" Else tagvalue = "FALSE"
            Case vbVariant    '12
                tagvalue = ""
            Case vbDataObject    '13
                tagvalue = ""
                '            Case vbDecimal    '14
                '                tagvalue = Trim(str(V))
                '            Case vbByte    '15
                '                tagvalue = Trim(str(V))
            Case Else
                On Error Resume Next
                Debug.Print V
                tagvalue = Trim(str(V))
            End Select


            If dict.Exists(dict_tagname) Then
                dict.ITEM(dict_tagname) = Trim(tagvalue)
            Else
                dict.Add dict_tagname, tagvalue
            End If

            If err.Number <> 0 Then block_PARAMETER_to_dictionary = False


        End If
    Next


End Function

Sub block_PROPERTYS_from_dictionary(entity As AcadEntity, dict As Scripting.DICTIONARY)
    On Error Resume Next
    If LCase(entity.ObjectName) <> "acdbblockreference" Then

        On Error GoTo 0
        Exit Sub
    End If
    Dim blockref As AcadBlockReference
    Dim ANGLE As String
    Dim scale_x As String
    Dim scale_y As String
    Dim scale_z As String
    Dim scaleX As String
    Dim scaleY As String
    Dim scaleZ As String
    Dim x As String
    Dim y As String
    Dim z As String

    Set blockref = entity
    Call TAG_FROM_DICTIONARY(dict, "BLOCKREF_ROTATION", ANGLE)
    Call TAG_FROM_DICTIONARY(dict, "BLOCKREF_EFF_SCALE_X", scale_x)
    Call TAG_FROM_DICTIONARY(dict, "BLOCKREF_EFF_SCALE_Y", scale_y)
    Call TAG_FROM_DICTIONARY(dict, "BLOCKREF_EFF_SCALE_Z", scale_z)
    Call TAG_FROM_DICTIONARY(dict, "BLOCKREF_SCALE_X", scaleX)
    Call TAG_FROM_DICTIONARY(dict, "BLOCKREF_SCALE_Y", scaleY)
    Call TAG_FROM_DICTIONARY(dict, "BLOCKREF_SCALE_Z", scaleZ)
    'Call TAG_FROM_DICTIONARY(dict, "BLOCKREF_EFFECTIVE_NAME", blockref.EffectiveName)
    Call TAG_FROM_DICTIONARY(dict, "BLOCKREF_INSERTATION_POINT_X", x)
    Call TAG_FROM_DICTIONARY(dict, "BLOCKREF_INSERTATION_POINT_Y", y)
    Call TAG_FROM_DICTIONARY(dict, "BLOCKREF_INSERTATION_POINT_Z", z)


    blockref.Rotation = val(ANGLE)
    blockref.XEffectiveScaleFactor = val(scale_x)
    blockref.YEffectiveScaleFactor = val(scale_y)
    blockref.ZEffectiveScaleFactor = val(scale_z)
    blockref.XScaleFactor = val(scaleX)
    blockref.YScaleFactor = val(scaleY)
    blockref.ZScaleFactor = val(scaleZ)

End Sub

Sub block_PROPERTYS_to_dictionary(entity As AcadEntity, dict As Scripting.DICTIONARY, Optional all As Boolean = False)
    If LCase(entity.ObjectName) <> "acdbblockreference" Then Exit Sub
    Dim blockref As AcadBlockReference
    Set blockref = entity
    Call TAG_TO_DICTIONARY(dict, "BLOCKREF_ROTATION", str(blockref.Rotation))
    Call TAG_TO_DICTIONARY(dict, "BLOCKREF_EFF_SCALE_X", str(blockref.XEffectiveScaleFactor))
    Call TAG_TO_DICTIONARY(dict, "BLOCKREF_EFF_SCALE_Y", str(blockref.YEffectiveScaleFactor))
    Call TAG_TO_DICTIONARY(dict, "BLOCKREF_EFF_SCALE_Z", str(blockref.ZEffectiveScaleFactor))
    Call TAG_TO_DICTIONARY(dict, "BLOCKREF_SCALE_X", str(blockref.XScaleFactor))
    Call TAG_TO_DICTIONARY(dict, "BLOCKREF_SCALE_Y", str(blockref.YScaleFactor))
    Call TAG_TO_DICTIONARY(dict, "BLOCKREF_SCALE_Z", str(blockref.XScaleFactor))

    Call TAG_TO_DICTIONARY(dict, "BLOCKREF_INSERTATION_POINT_X", str(blockref.InsertionPoint(0)))
    Call TAG_TO_DICTIONARY(dict, "BLOCKREF_INSERTATION_POINT_Y", str(blockref.InsertionPoint(1)))
    Call TAG_TO_DICTIONARY(dict, "BLOCKREF_INSERTATION_POINT_Z", str(blockref.InsertionPoint(2)))

    If all Then
        Call TAG_TO_DICTIONARY(dict, "BLOCKREF_EFFECTIVE_NAME", blockref.EffectiveName)
        Call TAG_TO_DICTIONARY(dict, "BLOCKREF_HANDLE", blockref.HANDLE)
        Call TAG_TO_DICTIONARY(dict, "BLOCKREF_LAYER", blockref.LAYER)
        Call TAG_TO_DICTIONARY(dict, "BLOCKREF_COLOR", blockref.color)
        Dim g As String
        g = GROUP_find_by_entity(entity)
        Call TAG_TO_DICTIONARY(dict, "BLOCKREF_GROUPS", g)
    End If
End Sub

------------------
Wer es nicht versucht, hat schon verlorn 
Und bei 3 Typos gibts den vierten gratis !
<<< for sale !

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

rexxitall
Mitglied
Dipl. -Ing. Bau


Sehen Sie sich das Profil von rexxitall an!   Senden Sie eine Private Message an rexxitall  Schreiben Sie einen Gästebucheintrag für rexxitall

Beiträge: 266
Registriert: 07.06.2013

Various: systems, Operating systems, cad systems, cad versions, programming languages.

erstellt am: 18. Mrz. 2016 14:07    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities Nur für zech 10 Unities + Antwort hilfreich

Glaub die hab ich unterschlagen
Um das scripting dictionary nutzen zu können mus auf die WSO.dll im windows system directory referenziert werden.


Sub TAG_TO_DICTIONARY(dict As Scripting.DICTIONARY, ByRef tagname As String, ByRef tagvalue As String)
    dict_tagname = Trim(tagname)
    If UCase(tagname) = tagname Then
        If dict.Exists(dict_tagname) Then
            dict.ITEM(dict_tagname) = Trim(tagvalue)
        Else
            dict.Add dict_tagname, tagvalue
        End If
    End If
End Sub


Sub TAG_FROM_DICTIONARY(dict As Scripting.DICTIONARY, ByRef tagname As String, tagvalue As String)
    dict_tagname = UCase(tagname)
    If dict.Exists(dict_tagname) Then tagvalue = Trim(dict.ITEM(dict_tagname))
End Sub

------------------
Wer es nicht versucht, hat schon verlorn 
Und bei 3 Typos gibts den vierten gratis !
<<< for sale !

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

zech
Mitglied



Sehen Sie sich das Profil von zech an!   Senden Sie eine Private Message an zech  Schreiben Sie einen Gästebucheintrag für zech

Beiträge: 89
Registriert: 09.11.2004

Autocad Architecture 2016
Civil3D 2016
Microstation
EliteCAD

erstellt am: 21. Mrz. 2016 06:03    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities

Hallo rexxitall,
danke für den sehr, sehr ausführlichen Lösungsvorschlag. Ich habe mir das ganze noch nicht angeschaut, glaube aber dass es zum gewünschten Ergebnis führt.
Da es mir aber als sehr aufwendig erscheint, habe ich mich für die einzeilige Lösung "SendCommand ...." entschieden.

Diesen Code kann ich bestimmt einmal an anderer Stelle gebrauchen wenn es um "Dictionary" Zugriffe geht.

Also vielen Dank und vorab
schon Frohe Ostern

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

rexxitall
Mitglied
Dipl. -Ing. Bau


Sehen Sie sich das Profil von rexxitall an!   Senden Sie eine Private Message an rexxitall  Schreiben Sie einen Gästebucheintrag für rexxitall

Beiträge: 266
Registriert: 07.06.2013

Various: systems, Operating systems, cad systems, cad versions, programming languages.

erstellt am: 24. Mrz. 2016 14:13    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities Nur für zech 10 Unities + Antwort hilfreich

Hi 

Ja der ist aufwendig *lach* und das gemeine ist, das der code stinklangweilig ist. Aber damit kann man als Ausgangsbasis recht viel damit anstellen  Block ersetzen, zurücksetzen, Werte clonen usw.

ebenso frohes Fest
Thomas

------------------
Wer es nicht versucht, hat schon verlorn 
Und bei 3 Typos gibts den vierten gratis !
<<< for sale !

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

Anzeige.:

Anzeige: (Infos zum Werbeplatz >>)

Darstellung des Themas zum Ausdrucken. Bitte dann die Druckfunktion des Browsers verwenden. | Suche nach Beiträgen

nächster neuerer Beitrag | nächster älterer Beitrag
Antwort erstellen


Diesen Beitrag mit Lesezeichen versehen ... | Nach anderen Beiträgen suchen | CAD.de-Newsletter

Administrative Optionen: Beitrag schliessen | Archivieren/Bewegen | Beitrag melden!

Fragen und Anregungen: Kritik-Forum | Neues aus der Community: Community-Forum

(c)2023 CAD.de | Impressum | Datenschutz