Author Topic: Explode non-uniform scaled Blocks  (Read 1562 times)

0 Members and 1 Guest are viewing this topic.

chobo

  • Newt
  • Posts: 24
Explode non-uniform scaled Blocks
« on: February 26, 2007, 08:07:05 PM »
I would like to perform Explode non-uniform scaled Blocks using VBA.
In this case, Is there only one way using SendCommand?
Suggestions please.
Code: [Select]
[color=green]'Bellow code is written by Randall Rath---------------------[/color]

Public Function ExplodeEX(oBlkRef As AcadBlockReference, _
    bKeep As Boolean) As Variant
    Dim objEnt As AcadEntity
    Dim objMT As AcadMText
    Dim objBlk As AcadBlock
    Dim objDoc As AcadDocument
    Dim objArray() As AcadEntity
    Dim objSpace As AcadBlock
    Dim intCnt As Integer
    Dim varTemp As Variant
    Dim varPnt As Variant
    Dim dblScale As Double
    Dim dblRot As Double
    Dim dblMatrix(3, 3) As Double
    On Error GoTo Err_Control
    'What document is the reference in?
    Set objDoc = oBlkRef.Document
    'Model space or layout?
    Set objSpace = objDoc.ObjectIdToObject(oBlkRef.OwnerID)
    Set objBlk = objDoc.Blocks(oBlkRef.Name)
    varPnt = oBlkRef.InsertionPoint
    dblScale = oBlkRef.XScaleFactor
    dblRot = oBlkRef.Rotation
    'Set the matrix for new objects transform
    '*Note:
    'This matrix uses only the X scale factor of the
    'Block reference, many entities can not be scaled
    'Non-uniformly!
    dblMatrix(0, 0) = dblScale
    dblMatrix(0, 1) = 0
    dblMatrix(0, 2) = 0
    dblMatrix(0, 3) = varPnt(0)
    dblMatrix(1, 0) = 0
    dblMatrix(1, 1) = dblScale
    dblMatrix(1, 2) = 0
    dblMatrix(1, 3) = varPnt(1)
    dblMatrix(2, 0) = 0
    dblMatrix(2, 1) = 0
    dblMatrix(2, 2) = dblScale
    dblMatrix(2, 3) = varPnt(2)
    dblMatrix(3, 0) = 0
    dblMatrix(3, 1) = 0
    dblMatrix(3, 2) = 0
    dblMatrix(3, 3) = 1
    'Get all of the entities in the block
    ReDim objArray(objBlk.Count - 1)
    For Each objEnt In objBlk
        Set objArray(intCnt) = objEnt
        intCnt = intCnt + 1
    Next objEnt
    'Place them into the correct space
    varTemp = objDoc.CopyObjects(objArray, objSpace)
    'Transform & rotate
    For intCnt = LBound(varTemp) To UBound(varTemp)
        Set objEnt = varTemp(intCnt)
        objEnt.TransformBy dblMatrix
        objEnt.Rotate varPnt, dblRot
    Next intCnt
    'Keep the block reference?
    If Not bKeep Then
        oBlkRef.Delete
    End If
    'Return all of the new entities
    ExplodeEX = varTemp
    'Release memory
    Set objDoc = Nothing
    Set objBlk = Nothing
    Set objSpace = Nothing
    Exit_Here:
    Exit Function
    Err_Control:
    MsgBox Err.Description
    Resume Exit_Here
End Function
« Last Edit: February 27, 2007, 10:33:23 AM by CmdrDuh »

Bryco

  • Water Moccasin
  • Posts: 1864
Re: Explode non-uniform scaled Blocks
« Reply #1 on: February 27, 2007, 12:36:24 AM »
Interesting problem.
I'ld say sendcommand looks pretty good with this one.
You could check the block for the type of ents and write functions for the ones that aren't too hard (Lines,plines,circles) but changing an ellipse to a spline is beyond me.

Glenn R

  • Water Moccasin
  • Posts: 1932
  • What idiot child of married cousins wrote this?!
Re: Explode non-uniform scaled Blocks
« Reply #2 on: February 27, 2007, 01:23:26 AM »
Autocad is doing some funky mojo in the EXPLODE command, with regards to non-uniformly scaled blocks, which isn't exposed in the API.

Bryco's suggestion, ugly as it is, is about the only way. No offence there Bryce ;)
Me

chobo

  • Newt
  • Posts: 24
Re: Explode non-uniform scaled Blocks
« Reply #3 on: February 28, 2007, 05:50:34 AM »
it's so shame..
Anyway, Thanks Bryco, Glenn R ..