Dear MarkoI believe it's because you have a dynamic rotation parameter & the actual rotation of the block is 0.
It also gives the same result as Lee's code but not as per requirement.
Dear MarkoI believe it's because you have a dynamic rotation parameter & the actual rotation of the block is 0.
It also gives the same result as Lee's code but not as per requirement.
@mailmaverick .. I'd be careful if I were you...Here too ?
It's just me .. new member + 1 post + exe = wary Ron.@mailmaverick .. I'd be careful if I were you...Here too ?
mailmaverick
Done
Private Sub CommandStart_Click()
On Error Resume Next
'-------------------+
Dim I As Long
Dim ii As Long
Dim VseBloki
Dim ImiaBloka As String
Dim ObiektiDlaVibora
Dim NovyBlok
Dim VstavitBlok
Dim VibranieObiekti
Dim VibranyiObiekti() As Object
Dim minExt As Variant
Dim maxExt As Variant
Dim BlokModel As Object
Dim Vsegotext As Long
Dim NameObject As String
Dim MassivDannih
Dim MassivDannih2
Dim FilterType(0) As Integer
Dim FilterData(0) As Variant
Dim TochkaVstavkiBloka(0 To 2) As Double
Dim BX As Double
Dim BY As Double
Dim BZ As Double
Dim oBlk 'As IAcadBlockReference2
Dim oProps As Variant
Dim oDblkProp
Dim vPick As Variant
Dim points(0 To 7) As Double
Dim plineObj 'As AcadPolyline
Dim VstavitBlokRotation As Double
Dim VstavitBlokZerkalo As Double
Dim point1(0 To 2) As Double
Dim CoordPoint As Variant
Dim mirrorObj
'----------------------------------------------------------------------------------+
'----------------------------------------------------------------------------------+
'проверка открыт ли CAD
StartCAD 'запуск или подключение к каду
If CADPodklusen <> True Then Exit Sub
'----------------------------------------------------------------------------------+
'----------------------------------------------------------------------------------+
'создаем блок
Set ObiektiDlaVibora = ThisDrawing.SelectionSets
For Each VibranieObiekti In ObiektiDlaVibora
If VibranieObiekti.Name = "VremeniiNabor" Then
'набор объектов
ThisDrawing.SelectionSets.Item("VremeniiNabor").Delete
Exit For
End If
Next
'определить новый набор объектов
Set VibranieObiekti = ThisDrawing.SelectionSets.Add("VremeniiNabor")
'выбрать на экране объекты
'----------------------------------------------------------------------------------+
'Перейти в Кад
DoEvents
DoEvents
AppActivate acad.Caption 'активировать кад
DoEvents
DoEvents
'----------------------------------------------------------------------------------+
FilterType(0) = 0
FilterData(0) = "INSERT"
VibranieObiekti.SelectOnScreen FilterType, FilterData
If Err Then Err.Clear: Exit Sub
If VibranieObiekti.Count - 1 = -1 Then
MsgBox "Selection empty !", vbExclamation
Exit Sub
End If
'----------------------------------------------------------------------------------+
'----------------------------------------------------------------------------------+
Dim oBlockRef 'As AcadBlockReference
For Each BlokModel In VibranieObiekti ' перебор объектов в наборе
NameObject = BlokModel.ObjectName
If NameObject = "AcDbBlockReference" Then
Dim Block
Set Block = BlokModel
ImiaBloka = BlokModel.Effectivename
'вставить блок в модель
Set VstavitBlok = ThisDrawing.ModelSpace.InsertBlock(Block.insertionPoint, ImiaBloka, Block.XScaleFactor, Block.YScaleFactor, Block.ZScaleFactor, 0)
'----------------------------------------------------------------------------------+
oProps = VstavitBlok.GetDynamicBlockProperties
For I = 0 To UBound(oProps)
Set oDblkProp = oProps(I)
If oDblkProp.PropertyName = "Angle" Then
VstavitBlokRotation = oDblkProp.Value '= Atn(1) '45 degree angle
End If
Next
'----------------------------------------------------------------------------------+
VstavitBlok.GetBoundingBox minExt, maxExt
points(0) = minExt(0)
points(1) = minExt(1)
points(2) = maxExt(0)
points(3) = minExt(1)
points(4) = maxExt(0)
points(5) = maxExt(1)
points(6) = minExt(0)
points(7) = maxExt(1)
Set plineObj = ThisDrawing.ModelSpace.AddLightWeightPolyline(points)
plineObj.Closed = True
'----------------------------------------------------------------------------------+
oProps = Block.GetDynamicBlockProperties
For I = 0 To UBound(oProps)
Set oDblkProp = oProps(I)
If oDblkProp.PropertyName = "Angle" Then
plineObj.Rotate Block.insertionPoint, oDblkProp.Value - VstavitBlokRotation
End If
If oDblkProp.PropertyName = "Flip state" Then
VstavitBlokZerkalo = oDblkProp.Value
End If
Next
'----------------------------------------------------------------------------------+
If VstavitBlokZerkalo = 1 Then
CoordPoint = Block.insertionPoint
point1(0) = CoordPoint(0): point1(1) = CoordPoint(1) + 1: point1(2) = CoordPoint(2)
Set mirrorObj = plineObj.Mirror(Block.insertionPoint, point1) 'Определите зеркальную ось
plineObj.erase
End If
VstavitBlok.erase
End If
Next
'----------------------------------------------------------------------------------+
'----------------------------------------------------------------------------------+
'указать точку вставки блока
'Перейти в Кад
DoEvents
DoEvents
AppActivate acad.Caption 'активировать кад
DoEvents
DoEvents
'----------------------------------------------------------------------------------+
MsgBox "Ok!", vbSystemModal + vbInformation
'----------------------------------------------------------------------------------+
End Sub
HiYou should revise your example picture in the first post "Third Image : The Bounding Box which I want" .. the current one shows the desired result as the entire block bounding box.
...
Also, I need bounding box of only the Text Part "JJ-1" and not the entire block.
...
Hi
Maratovich's solution seems OK but I need the LISP code, not VB6.
Also, I need bounding box of only the Text Part "JJ-1" and not the entire block.
Thanks.
Master_Shake,
Since the text attribute is within a Block (which is not exploded), we cannot use vla-getBoundingBox function on it.
It gives following error :- "Automation Error. Null extents".
(defun _GetBoundingBox ( object / a b )
(vl-catch-all-apply 'vlax-invoke-method (list object 'GetBoundingBox 'a 'b))
(if a (mapcar 'vlax-safearray->list (list a b)))
)Once again Lee Mac to the rescue. Your code works perfect.
Thanks a lot Lee.
I like your subfunctions Lee,
Although for LM:points->boundingbox wouldnt a more adequate function naming be LM:points->4ptboundingbox ?