Topic: Min Bounding Box of INSERT

[mailmaverick]

Hi All,

I am using Minimum Bounding Box function as given at : http://lee-mac.com/minboundingbox.html
for constructing Minimum Bounding Box of a text Attribute within a Block.

First Image : My Block.
Second Image : The Bounding Box which I get.
Third Image : The Bounding Box which I want.

AutoCAD Drawing is also attached.

[ribarm]

See can this be of some help :
https://www.theswamp.org/index.php?topic=50205.0

[mailmaverick]

Dear Marko

It also gives the same result as Lee's code but not as per requirement.

[ChrisCarlson]

How would you want to accomplish this? It's certainly doable, I would figure out how to get the height of the attribute first, then apply an offset factor perpendicular to the orientation (your text is 3.3071mm tall but the bounding box appears to be slightly larger), find the intersections, and lastly create the box.

[ronjonp]

Dear Marko

It also gives the same result as Lee's code but not as per requirement.

I believe it's because you have a dynamic rotation parameter & the actual rotation of the block is 0.

[mailmaverick]

Dear Marko

It also gives the same result as Lee's code but not as per requirement.

I believe it's because you have a dynamic rotation parameter & the actual rotation of the block is 0.

Dear Marko

If I Change the Dynamic Rotation Parameter to 0 and give the rotation value to the Rotation of the block, it works fine.
Now my other problem, I want the bounding box of the text part only which is much smaller than the line. Sorry for my mistake in my original question, I want bounding Box of only the text part, without the line.

[maratovich]

mailmaverick
Done

Due diligence:
kdub: Zip file containing .EXE file removed. 2017-04-06

[ronjonp]

@mailmaverick .. I'd be careful if I were you...

[maratovich]

@mailmaverick .. I'd be careful if I were you...

Here too ?

[ronjonp]

@mailmaverick .. I'd be careful if I were you...

Here too ?

It's just me .. new member + 1 post + exe = wary Ron.

[ChrisCarlson]

mailmaverick
Done

Post the source?

[maratovich]

 
Created on VB6, analogue of the VBA therefore = exe
Main thing is that the author could solve problem.
Waiting for author's reply to  topic.

Code: [Select]

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


[CAB]

The point is it is irresponsible to run an EXE file from an unknown source on your computer.
Who knows what malicious software could be installed.
You would be a fool to run it at work.

WARNING - RUN EXE FILES AT YOUR OWN RISK!

[MP]

I'm surprised the attachments remain intact. Due diligence is far more important than worrying about stepping on new toes.

[Refri]

Why deleted?
If you are afraid of a black cat in a black room - install an antivirus. (I will reveal the secret - there is no cat in the room)
Where can I get the file to check the result?