Nach dem Hinweis von KlaK
Diese Routinen verschieben den Nullpunkt eines Blockes auf einem vom Anwender gewünschten Punkt.
NACHDEM dieser Block als Blockreferenz bereist in der Zeichnung eingefügt wurde.
Und das auch wenn diese Blockreferenz verzerrt, verschobnn und gedreht wurden.
Hierbei bleiben die bereits eingefügten Blockrefernzen wahlweise da wo sie eingefügt worden sind, oder ändern gemäß neuem Punkt die Position.
Die Zweite Routine arbeitet ähnlich, fügt dem verzerrten Block jedoch neue Elemente hinzu.
Also drübermalen, Routine nd die Elemente werden DER BLOCKDEFINITION hinzugefügt.
Wie gesagt dabei ist es egal wie diese Blockreferenz vorher "verfrickelt" wurde.
Man kann also eine Vermessungszeichnung in Weltkoordinaten als Block einfügen
die so positionieren und skalieren das sie Lokale Bauwerkskoordinaten bekommt
und dann z.B. die Bauwerksgrenzen drübermalen und zu dem Block hinzufügen.
Speichert man den Block hat man seine Vermessungszeichnung ohne viel Aufriss
auf dem neuesten Stand gebracht. z.B. für den Bauantrag.
Umgekehrt hilft es auch, wenn der Vermesser neue Punkte aufgenommen hat.
Und für die "Normalsterblichen" :
Ich hab mich immer geärgert das ich immer erst im Blockeditor gemerkt hab,
das ich vergessen hatte einige Elemente zu markieren.
Na klar erst dann, nachdem der Block schon eingefügt wurde.
Diese Elemente dann nachträglich hinzuzufügen bereitete dann immer "große" Freude.
Just from the workbench.
Somehow i never found a working example how to just add a few entitys to a block definition or just even move the block insertation point.
OK Lee Mac has written a nice working ones in lisp. But i do not like mixed programming so much. 
So something to play with.
Works on multiple scaled blocks even if they are rotated.
there was a glich with a wrong loop variable. Should now also work with more then one entity I correct it here.
have fun
Thomas
Public Function block_def_entitys_add_from_selection_set(selectionsetobject As AcadSelectionSet, Optional delsource As Boolean = True) As Boolean
block_entitys_add_from_selection_set = False
Dim BLOCKS As AcadBlocks
Dim BLOCK As AcadBlock
Dim ENTITYS() As AcadEntity
Dim FAKEARR() As AcadEntity
Dim ENTITY As AcadEntity
Dim blockref As AcadBlockReference
Dim blockname As String
Dim I As Integer
Dim HANDLE As String
Dim objectid As String
Dim V As Variant
Dim ZERO(2) As Double
Dim TMPBLK As AcadBlock
Dim TMPREF As AcadBlockReference
Dim C As Long
Dim TRANSLATION(2) As Double
Dim SCALING(2) As Double
Dim ROTATION As Double
Dim FOUND As Boolean
Dim ANGLE As Double
Dim IP As Variant
Dim ACTIVESPACE As AcadBlock 'model or Paperspave are simle block definitions 
Set ACTIVESPACE = GetActiveSpace() 'Detect the current active space
Thisdrawing.PURGEALL
If selectionsetobject.Count < 2 Then Exit Function
'find block
FOUND = False
V = ZERO
For Each ENTITY In selectionsetobject
If LCASE(ENTITY.ObjectName) = "acdbblockreference" Then
Set blockref = ENTITY
blockname = blockref.EffectiveName
Set BLOCK = Thisdrawing.BLOCKS(blockname)
V = blockref.InsertionPoint
IP = V
ScaleX = blockref.XScaleFactor
ScaleY = blockref.YScaleFactor
scaleZ = blockref.ZScaleFactor
ANGLE = blockref.ROTATION
HANDLE = ENTITY.HANDLE
FOUND = True
Exit For
End If
Next
If Not FOUND Then Exit Function
On Error GoTo 0
TRANSLATION(0) = -1 * V(0)
TRANSLATION(1) = -1 * V(1)
TRANSLATION(2) = -1 * V(2)
SCALING(0) = 1 / ScaleX
SCALING(1) = 1 / ScaleY
SCALING(2) = 1 / scaleZ
ROTATION = -ANGLE
'put everything in a block exept the first blockreference found
ReDim ENTITYS(selectionsetobject.Count - 2)
For Each ENTITY In selectionsetobject
If ENTITY.HANDLE <> HANDLE Then
ENTITY.Rotate IP, ROTATION 'rotate the new entitys back at the first place !
'Application.Update
Set ENTITYS(C) = ENTITY
C = C + 1
End If
Next
'insert block as blockref by the inverted destination block propertys
V = ZERO
Set TMPBLK = Thisdrawing.BLOCKS.Add(IP, "TMPBLK") 'add a block with the current insertation point of blockref as zero
TMPBLK.BlockScaling = acAny 'block can now be scaled in ANY direction
If TMPBLK.Count > 0 Then 'if we have a left over from a previous run we have to cler this block
For Each ENTITY In TMPBLK
ENTITY.DELETE
Next
End If
Thisdrawing.CopyObjects ENTITYS, TMPBLK 'copy all objects to add to the temporary block definition
'Call ACTIVESPACE.InsertBlock(ZERO, BlockName, 1, 1, 1, 0)
Set TMPREF = ACTIVESPACE.InsertBlock(ZERO, "TMPBLK", SCALING(0), SCALING(1), SCALING(2), 0)
'Application.Update
'
' TMPREF.Move ZERO, TRANSLATION
'Application.Update
' If I = 2 Then
'
' TMPREF.XScaleFactor = SCALING(0)
' Application.Update
' TMPREF.YScaleFactor = SCALING(1)
' Application.Update
' TMPREF.ZScaleFactor = SCALING(2)
' Application.Update
' TMPREF.Update
' Call TMPREF.Rotate(V, ROTATION)
' End If
'
' 'insert the blockref into the targetblock, explode and delete temporary block definition
Application.Update
ReDim FAKEARR(0)
Set FAKEARR(0) = TMPREF
Thisdrawing.CopyObjects FAKEARR, BLOCK
For Each ENTITY In BLOCK
If LCASE(ENTITY.ObjectName) = "acdbblockreference" Then
Set blockref = ENTITY
If blockref.EffectiveName = "TMPBLK" Then
blockref.EXPLODE
blockref.DELETE
Exit For
End If
End If
Next
On Error Resume Next
TMPBLK.DELETE
If delsource Then
For I = 0 To UBound(ENTITYS)
ENTITYS(I).DELETE
Next
End If
Thisdrawing.REGEN acAllViewports
TMPREF.DELETE
End Function
Public Function block_def_set_new_insertation_point(selectionsetobject As AcadSelectionSet, Optional delsource As Boolean = True) As Boolean
block_entitys_add_from_selection_set = False
Dim BLOCKS As AcadBlocks
Dim BLOCK As AcadBlock
Dim ENTITYS() As AcadEntity
Dim FAKEARR() As AcadEntity
Dim ENTITY As AcadEntity
Dim blockref As AcadBlockReference
Dim blockname As String
Dim I As Integer
Dim HANDLE As String
Dim objectid As String
Dim V As Variant
Dim ZERO(2) As Double 'dont touch this variable !
Dim TMPBLK As AcadBlock
Dim TMPREF As AcadBlockReference
Dim C As Long
Dim TRANSLATION(2) As Double
Dim SCALING(2) As Double
Dim ROTATION As Double
Dim FOUND As Boolean
Dim ANGLE As Double
Dim IP As Variant
Dim NEWPOINT(2) As Double
Dim FROMPOINT As Variant
Dim TOPOINT As Variant
Dim POINT As AcadPoint
Dim POINT2 As AcadPoint
Dim CALCPOINT() As Double
Dim REFLIST() As Point3D
Dim MINPOINT As Variant
Dim MAXPOINT As Variant
On Error GoTo 0
Dim ACTIVESPACE As AcadBlock 'model or Paperspave are simle block definitions
Set ACTIVESPACE = GetActiveSpace() 'Detect the current active space
Dim DEFINITIONS
Thisdrawing.PURGEALL
Application.Update
If selectionsetobject.Count < 1 Then Exit Function
'find block
FOUND = False
V = ZERO
For Each ENTITY In selectionsetobject
If LCASE(ENTITY.ObjectName) = "acdbblockreference" Then
Set blockref = ENTITY
blockname = blockref.EffectiveName
Set BLOCK = Thisdrawing.BLOCKS(blockname)
V = blockref.InsertionPoint
IP = V
ScaleX = blockref.XScaleFactor
ScaleY = blockref.YScaleFactor
scaleZ = blockref.ZScaleFactor
ANGLE = blockref.ROTATION
HANDLE = ENTITY.HANDLE
FOUND = True
Exit For
End If
Next
If Not FOUND Then Exit Function
If SLOPEFORM.CHKKEEPPOS Then
'make a list with all current blockref definitions and its bounding box min point
C = 0
ReDim REFLIST(1000)
For Each BLOCK In Thisdrawing.BLOCKS
For Each ENTITY In BLOCK
If LCASE(ENTITY.ObjectName) = "acdbblockreference" Then
Set blockref = ENTITY
If C > UBound(REFLIST) Then
ReDim Preserve REFLIST(UBound(REFLIST) + 1000)
End If
If blockname = blockref.EffectiveName Then
Call blockref.GetBoundingBox(MINPOINT, MAXPOINT)
REFLIST(C).x = MINPOINT(0)
REFLIST(C).y = MINPOINT(1)
REFLIST(C).Z = MINPOINT(2)
REFLIST(C).info = blockref.HANDLE
C = C + 1
End If
End If
Next
Next
End If
ReDim Preserve REFLIST(C - 1)
On Error GoTo 0
TRANSLATION(0) = -1 * V(0)
TRANSLATION(1) = -1 * V(1)
TRANSLATION(2) = -1 * V(2)
SCALING(0) = 1 / ScaleX
SCALING(1) = 1 / ScaleY
SCALING(2) = 1 / scaleZ
ROTATION = -ANGLE
If Not get_POINT("NEW INSERTATIN POINT", NEWPOINT) Then Exit Function
Set POINT = ACTIVESPACE.AddPoint(NEWPOINT)
'put point in a array
ReDim ENTITYS(0)
Set ENTITYS(0) = POINT
ENTITYS(0).Rotate IP, ROTATION 'rotate the point back.
'so if the blockref wouldnt be rotate those points should match
' Application.Update
'insert block as blockref by the inverted destination block propertys
V = ZERO
Set TMPBLK = Thisdrawing.BLOCKS.Add(IP, "TMPBLK") 'add a block with the current insertation point of blockref as zero
If TMPBLK.Count > 0 Then 'if we have a left over from a previous run we have to cler this block
For Each ENTITY In TMPBLK
ENTITY.DELETE
Next
End If
Thisdrawing.CopyObjects ENTITYS, TMPBLK 'copy newpoint to the temporary block definition
TMPBLK.BlockScaling = acAny 'block can be scaled in any direction
'Call ACTIVESPACE.InsertBlock(ZERO, BlockName, 1, 1, 1, 0)
Set TMPREF = ACTIVESPACE.InsertBlock(ZERO, "TMPBLK", SCALING(0), SCALING(1), SCALING(2), 0)
'now the point has the reversed translation, scaling, rotation.
'in simple words he has the same coordinate system as the target block was defined
' Application.Update
' Thisdrawing.SendCommand "regen" & vbLf
' Set BLOCK = Thisdrawing.BLOCKS("TMPBLK")
' For Each ENTITY In BLOCK
' Debug.Print ENTITY.ObjectName
' Next
'we xplode the temporary blockref
'Thisdrawing.REGEN acAllViewports
Dim explodedObjects As Variant
Dim ss As AcadSelectionSet
Set ss = Thisdrawing.SelectionSets.Add(Now)
explodedObjects = TMPREF.EXPLODE
ss.Select acSelectionSetLast
Set ENTITY = ss.ITEM(0)
ss.DELETE
Set POINT2 = ENTITY
'POINT2.color = acYellow
'Application.Update
V = POINT2.COORDINATES 'should contain point coordinate
POINT.DELETE
POINT2.DELETE
TMPREF.DELETE
'move all entitys to the new point
Set BLOCK = Thisdrawing.BLOCKS(blockname)
For Each ENTITY In BLOCK
Call ENTITY.Move(V, ZERO)
Application.Update
Next
If SLOPEFORM.CHKKEEPPOS Then
For I = 0 To UBound(REFLIST)
FROMPOINT = ZERO
TOPOINT = ZERO
Set blockref = Thisdrawing.HandleToObject(REFLIST(I).info)
Call blockref.GetBoundingBox(TOPOINT, MAXPOINT)
FROMPOINT(0) = REFLIST(I).x
FROMPOINT(1) = REFLIST(I).y
FROMPOINT(2) = REFLIST(I).Z
blockref.Move TOPOINT, FROMPOINT
Next
End If
On Error Resume Next
TMPBLK.DELETE
Thisdrawing.REGEN acAllViewports
TMPREF.DELETE
If ACTIVESPACE.name = "*Model_Space" Then
Thisdrawing.ACTIVESPACE = acModelSpace
Else
Thisdrawing.ACTIVESPACE = acPaperSpace
End If
End Function
------------------
Wer es nicht versucht, hat schon verlorn 
Und bei 3 Typos gibts den vierten gratis !
<<< for sale !
[Diese Nachricht wurde von rexxitall am 29. Sep. 2016 editiert.]
[Diese Nachricht wurde von rexxitall am 02. Okt. 2016 editiert.]
Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP
Foren auf CAD.de (alle Foren)
| 
