Topic: extrude region from exploded block

[David Hall]

OK, I'm pulling my hair out, I am trying to create an extruded solid from a region, which is an exploded block. (My thought was to draw the region, and insert it as a block, then explode block, leaving the region I could then extrude.)  Should I be trying this, or use a polyline instead?  I guess I could draw a polyline based on coordinates from a single pick point, but that seemed like too much work. Or could I change my block from a region to a polyline, and extrude that?  Anyway, Im crashing when I try to capture the exploded block.  Is there a way to do this?

[David Hall]

I started with some other code, thus all the commented lines

Code: [Select]

Public Sub DrawWideFlangeSteel()

      Dim oCyl As Acad3DSolid, oCircle As AcadCircle, oLine As AcadLine, oLayer As AcadLayer
      Dim oBeam As Acad3DSolid, oReg As AcadRegion, oBlock As AcadBlockReference, oObject As AcadObject
      Dim varpick As Variant
      Dim Ent As AcadEntity
      Dim Inspt As Variant
      Dim RegEnt(0) As AcadEntity
      Dim V(2) As Double, Unit As Double, Vn(2) As Double, dblBusDia As Double
      Dim P1, P2
      Dim newPT1 As Variant
      Dim newPT2 As Variant
      Set oLayer = ThisDrawing.Layers.Add("3D-BUSS-STEEL")
      oLayer.color = 235
     
      Inspt = ThisDrawing.Utility.GetPoint(, "Pick Insertion Point: ")
      If ThisDrawing.ActiveSpace = acModelSpace Then
      Set oBlock = ThisDrawing.ModelSpace.InsertBlock(Inspt, "M:\MODEL-COMPONENTS\w8x24.dwg", 1#, 1#, 1#, 0)
      Else
      Set oBlock = ThisDrawing.PaperSpace.InsertBlock(Inspt, "M:\MODEL-COMPONENTS\w8x24.dwg", 1#, 1#, 1#, 0)
      End If
      ThisDrawing.Regen acActiveViewport
Set oObject = oBlock.Explode

'      ThisDrawing.Utility.GetEntity Ent, varpick
'      If Not TypeOf Ent Is AcadLine Then
'            MsgBox "That was not a Layout Line"
'            Exit Sub
'      End If
'      Set oLine = Ent
'      newPT1 = oLine.StartPoint
'      newPT2 = oLine.EndPoint
'      newPT1(2) = ConvertFeet(frmInsPart.cboBusHeight.Value)
'      newPT2(2) = ConvertFeet(frmInsPart.cboBusHeight.Value)
'      Set oLine = ThisDrawing.ModelSpace.AddLine(newPT1, newPT2)
'      oLine.Layer = "3D-BUSS-CALC"
'      P1 = oLine.StartPoint: P2 = oLine.EndPoint
'      V(0) = P2(0) - P1(0): V(1) = P2(1) - P1(1): V(2) = P2(2) - P1(2)
      'Normalise the vector(It's length=1)
'      Unit = Sqr(V(0) * V(0) + V(1) * V(1) + V(2) * V(2))
'      Vn(0) = V(0) / Unit: Vn(1) = V(1) / Unit: Vn(2) = V(2) / Unit
'      dblBusDia = CDbl(frmInsPart.cboBusSize.Value + 0.5) / 2
'      Set oCircle = ThisDrawing.ModelSpace.AddCircle(oLine.StartPoint, dblBusDia)
      ThisDrawing.Regen acActiveViewport
'      oCircle.Normal = Vn    ' Vn or V both work here.
'      ThisDrawing.Regen acActiveViewport
'      Set RegEnt(0) = oCircle
'      oReg = ThisDrawing.ModelSpace.AddRegion(RegEnt)
'      Set oCyl = ThisDrawing.ModelSpace.AddExtrudedSolid(oReg(0), oLine.Length, 0)
'      oCircle.Delete
'      oReg(0).Delete
End Sub

[Jeff_M]

Whoa there, take a deep breath, relax.....there, now doesn't that feel better?

OK, now that we have you back, care to try again? Draw, Insert, Explode, Extrude......could you explain WHY you'd want to do it this way? What is your intent?

To get the objects of an exploded object:
Dim newObjs As Variant
newobjs = MyInsertedBlock.Explode
'Only 1 object in this block
Dim oEntity as AcadEntity
Set oEntity = newObjs(0)

And as I was composing this you posted the code that pretty much answered my questions.......but note how I get the exploded region.......

[David Hall]

Whoa there, take a deep breath, relax.....there, now doesn't that feel better?

Yes, much, thank you

OK, now that we have you back, care to try again? Draw, Insert, Explode, Extrude......could you explain WHY you'd want to do it this way? What is your intent?

Ok, long story short, Im in the process of creating a 3D substation design tool, that will help draw an electrical substation in 3d, and spit out a BOM, and stuff.  I was using 8" tube steel for most of my steel supports, but we sometimes use wide flange beams for the supports.  Once done, Im going to post it here for anyone interested in testing/use in the real world.

[David Hall]

Dim newObjs As Variant
newobjs = MyInsertedBlock.Explode

Is this where I went wrong?  I needed a variant to capture the exploded stuff?  I tried
Dim oSomething as AcadObject
oSomething = block.explode
which didn't work

[Jeff_M]

Is this where I went wrong?  I needed a variant to capture the exploded stuff? 

Yep, that's it. And it will be an array of the objects in the block.

[Fatty]

Sorry, Commandor
I think your main problem is on you
can't to create the region in other than XY WCS plane
First create region and then rotate3d it in desired
normal
Maybe I am wrong though

~'J'~

[David Hall]

Thanks Jeff, I knew it could be done, I just couldn't find that piece of info

[David Hall]

OK, since I already started this thread, I figure I can continue here.  The above code is all fixed and working great.  I have a new issue in that I am creating 3 3dsolids, separately, and would like to union them together.

Code: [Select]

Public Sub AddDeadEnd(PhSpace As Double, PoleSp As Double, PoleHt As Double, BmHt As Double)
      Const VK_ESCAPE = &H1B
      Const VK_LBUTTON = &H1
      Const VK_SPACE = &H20
      Const VK_RETURN = &HD
      Const VK_LEFT = &H25
      On Err GoTo err_control
      Dim inspt As Variant, dblRotation As Double, dblTOC As Double, leftLeg As Variant, rightLeg As Variant
      Dim oCurrLayeR As AcadLayer, intAutoSnap As Integer, intOSMode As Integer, PI As Double, LL2 As Variant
      Dim oPline As AcadLWPolyline, oEntity(0) As AcadEntity, regent(0) As AcadEntity, obj3d As Acad3DSolid
      Dim objRegion
      Set oCurrLayeR = ThisDrawing.ActiveLayer
      'IsSetup
      dblTOC = CDbl(InputBox("What is T.O.C. elevation? ie 12 or 0 or -12"))
      ThisDrawing.SetVariable "ORTHOMODE", 1
      intAutoSnap = ThisDrawing.GetVariable("AUTOSNAP")
      ThisDrawing.SetVariable "AUTOSNAP", 0
      intOSMode = ThisDrawing.GetVariable("OSMODE")
      ThisDrawing.SetVariable "OSMODE", 32
      inspt = ThisDrawing.Utility.GetPoint(, "Select Deadend Insertion Point: ")
      ThisDrawing.SetVariable "OSMODE", 512
      dblRotation = ThisDrawing.Utility.GetAngle(inspt, "Pick Line Direction: ")
      PI = Atn(1) * 4

      ThisDrawing.SetVariable "OSMODE", 0
      inspt(2) = inspt(2) + dblTOC
      leftLeg = ThisDrawing.Utility.PolarPoint(inspt, dblRotation - ((PI * 90) / 180), PoleSp / 2)
      rightLeg = ThisDrawing.Utility.PolarPoint(inspt, dblRotation + ((PI * 90) / 180), PoleSp / 2)
      Call LayerSet("3D-STEL", 235)
      DrawDeadendPole leftLeg, PoleHt
      DrawDeadendPole rightLeg, PoleHt
      leftLeg(2) = leftLeg(2) + BmHt
      Set oPline = ThisDrawing.ModelSpace.AddLightWeightPolyline(PolygonVexs(leftLeg, 8, 5))
      oPline.Closed = True
      oPline.Elevation = BmHt
      oPline.Update
      Set regent(0) = oPline
      objRegion = ThisDrawing.ModelSpace.AddRegion(regent)
      Set obj3d = ThisDrawing.ModelSpace.AddExtrudedSolid(objRegion(0), PoleSp, 0)
      regent(0).Delete
      objRegion(0).Delete
     
      LL2 = ThisDrawing.Utility.PolarPoint(leftLeg, dblRotation, 12)
      obj3d.Rotate3D leftLeg, LL2, ((PI * -90) / 180)
Exit_Here:
      ThisDrawing.ActiveLayer = oCurrLayeR
      ThisDrawing.SetVariable "AUTOSNAP", intAutoSnap
      ThisDrawing.SetVariable "OSMODE", intOSMode
      ThisDrawing.SetVariable "INSUNITS", 1
      Exit Sub
err_control:
      Select Case Err.Number
      Case -2147352567
      'Debug.Print Err.Number, Err.Description
            varcancel = ThisDrawing.GetVariable("LASTPROMPT")
            If InStr(1, varcancel, "*Cancel*") <> 0 Then
                  If GetAsyncKeyState(VK_ESCAPE) And 8000 > 0 Then
                        Err.Clear
                        Resume Exit_Here
                  ElseIf GetAsyncKeyState(VK_LBUTTON) > 0 Then
                        Err.Clear
                        Resume
                  End If
            Else
                  If GetAsyncKeyState(VK_SPACE) Then
                        Resume Exit_Here
                  End If
      'Missed the pick, send them back!
                  Err.Clear
                  Resume
            End If
      Case Else
            MsgBox Err.Description
            Resume Exit_Here
      End Select
End Sub
DrawDeadendPole leftLeg and Right leg are the first 2 3d objs, the 3rd you can see at the bottom of the code.

the code for that is

Code: [Select]

Private Sub DrawDeadendPole(insptpole As Variant, PoleHt As Double)
      Dim dblBase As Double, dblTop As Double, dblHeight As Double
      Dim obj3d As Acad3DSolid, regent(0) As AcadEntity
      Dim oPline As AcadLWPolyline
      Dim cenPt As Variant, iNum As Integer, intAutoSnap As Integer
      Dim dblAng As Double, dblRad As Double, dblAngle As Double
      Dim objRegion

      dblHeight = PoleHt
      dblTop = 18 / 2
      dblAngle = Atn((dblTop - dblBase) / dblHeight)
      iNum = 12
      cenPt = insptpole
      dblRad = 29 / 2
      Set oPline = ThisDrawing.ModelSpace.AddLightWeightPolyline(PolygonVexs(cenPt, iNum, dblRad))
      oPline.ConstantWidth = 0
      oPline.Layer = "0"
      oPline.Closed = True
      oPline.Update
      Set regent(0) = oPline
      objRegion = ThisDrawing.ModelSpace.AddRegion(regent)
      Set obj3d = ThisDrawing.ModelSpace.AddExtrudedSolid(objRegion(0), dblHeight, dblAngle)
      regent(0).Delete
      objRegion(0).Delete
      ThisDrawing.Regen acActiveViewport

End Sub
Function PolygonVexs(cenPt As Variant, iNum As Integer, _
                     dblRad As Double, Optional mode As Integer = 0) As Variant
      Dim tmpPt As Variant
      Dim iCnt As Integer
      Dim vCnt As Integer
      Dim vxCnt As Integer
      Dim PI As Double
      PI = Atn(1) * 4
      Dim dltAng As Double
      Dim dblAng As Double
      Dim initAng As Double
      dltAng = 2 * PI / iNum
      initAng = dltAng / 2
      vxCnt = 2 * iNum - 1
      iCnt = 0
      vCnt = 0
      ReDim ptsarr(0 To vxCnt) As Double
      If mode = 0 Then dblRad = dblRad / Cos(dltAng / 2)
      While iCnt < iNum
            dblAng = initAng + dltAng * iCnt
            tmpPt = ThisDrawing.Utility.PolarPoint(cenPt, dblAng, dblRad)
            iCnt = iCnt + 1
            ptsarr(vCnt) = tmpPt(0): ptsarr(vCnt + 1) = tmpPt(1)
            vCnt = vCnt + 2
      Wend
      PolygonVexs = ptsarr
End Function


Anyway, the question is how can I capture the 3d solids as they are created to use the Boolean union later

[David Hall]

I tried making DrawDeadendPole a Function and using Set 3dobj=DrawDeadendPole
but that didn't work.  I might have been doing it wrong or didn't Dim the correct entity to begin with.  I'm thinking this is the way to go, I just haven't figured it out yet.

[CADaver]

Side track...
1.)  You can extrude closed polylines, no need for region.
2.)  If you already have a block, just change the X or Z scale.

Pseudo code.
Collect profile data from file
Draw pline profile
Extrude profile one unit (X for beams or Z for cols.)
Add intelligence (attributes, xdata, whatever)
Makeblock
Insert block, modify X or Z to desired length and rotate.

X or Z values are extractable along with block name, location, layer, etc. with EATTEXT.

[David Hall]

Cadaver, how do you extrude a closed polyline?  from the help file, it says region only

RetVal = object.AddExtrudedSolid(Profile, Height, TaperAngle)

Object

ModelSpace Collection, PaperSpace Collection, Block
The object or objects this method applies to.

Profile

Profile object; input-only
The Region object only.

Height

Double; input-only
The height of the extrusion along the Z axis of the object's coordinate system. If you enter a positive number, AutoCAD extrudes the object along the positive Z axis. If you enter a negative number, AutoCAD extrudes the object along the negative Z axis.

TaperAngle

Double; input-only
The taper angle of the extrusion must be provided in radians. The range of the taper angle is from -90 to +90 degrees.
Positive angles taper in from the base, negative angles taper out. The default angle, 0, extrudes a 2D object perpendicular to its plane.

RetVal

3DSolid object
A 3DSolid object as the newly created extruded solid.

[Jeff_M]

Here's one way, Duh.

Code: [Select]

Private Function DrawDeadendPole(insptpole As Variant, PoleHt As Double) As Acad3DSolid
....all your code to create the solid
      objRegion(0).Delete
      ThisDrawing.Regen acActiveViewport
      Set DrawDeadendPole = obj3D
End Sub
Then in the calling Sub:

Code: [Select]

...blah blah blah
     Call LayerSet("3D-STEL", 235)
     Dim LeftPole as Acad3dSolid
     Dim RightPole as Acad3dSolid
      Set LeftPole = DrawDeadendPole(leftLeg, PoleHt)
      Set RightPole = DrawDeadendPole(rightLeg, PoleHt)
      leftLeg(2) = leftLeg(2) + BmHt
....more blah....
This will give you your 3 solids to Union

[David Hall]

I will have to give that a try.  Thanks Jeff

[David Hall]

That worked great!!!  I was so close, I was just missing a few things.  Thanks again Jeff

[Jeff_M]

You're welcome, I'm glad I could help!

[MickD]

Hi All,

I have to knock out a quick modeling app similar to this, I don't have time to do it in a LL language and it will be more of a prototype to be ported later if all works well.

Anyway, I've borrowed some of Duh's code and I have a small problem, I have a library of shapes as polylines already to go, what I want to do is insert the polyline as a block, explode it to get the polyline and extrude it but I'm getting a 'self reference' error, here's the code so far.

Code: [Select]

Public Sub DrawSection()
      Dim oLayer As AcadLayer
      Dim oBeam As Acad3DSolid, oReg As AcadRegion, oBlock As AcadBlockReference, oObject As Variant
      Dim Inspt As Variant
      Dim RegEnt(0) As AcadEntity

      Set oLayer = ThisDrawing.Layers.Add("3D-mbr")
      oLayer.color = 235
     
      Inspt = ThisDrawing.Utility.GetPoint(, "Pick Insertion Point: ")
     
      Set oBlock = ThisDrawing.ModelSpace.InsertBlock(Inspt, "C:\DCS3d\310UB040.dwg", 1#, 1#, 1#, 0) '<--self ref error here

      ThisDrawing.Regen acActiveViewport
      Set oObject = oBlock.Explode
      ThisDrawing.Regen acActiveViewport
      Set RegEnt(0) = oObject
      oReg = ThisDrawing.ModelSpace.AddRegion(RegEnt)
      Set oBeam = ThisDrawing.ModelSpace.AddExtrudedSolid(oReg(0), 1000, 0)
      oReg(0).Delete
End Sub

Once I get this sorted I will add code to look up the file by name and let the user select the appropriate section, add some data to it for BOM's and manipulation and transform it into it's final place.

tia,
Mick.

[SEANT]

I can’t recreate that error here (AutoCAD 2004), even with the C:\DCS3d\310UB040.dwg active.

Generating the appropriate solid, however,  wouldn't happen until modifications (see earlier post by Jeff_M) were made to these lines of code:

      oObject = oBlock.Explode  '<---------------------
      ThisDrawing.Regen acActiveViewport
      Set RegEnt(0) = oObject(0) '<---------------------
      oReg = ThisDrawing.ModelSpace.AddRegion(RegEnt)
      Set oBeam = ThisDrawing.ModelSpace.AddExtrudedSolid(oReg(0), 1000, 0)

[kpblc]

Try this one (i didn't test it):

Code: [Select]

Public Function DrawSection(Optional DWGPath As String = "c:\DCS3d", _
  Optional DWGName As String = "310UB040") As AcadObject
' DWGPath - path to dwg-file (w/o splash)
' DWGName - file name w/o extension
' There is no control for these parameters
Dim objLayer As AcadLayer, objBeam As Acad3DSolid, objRegion As AcadRegion
Dim objBlockRef As AcadBlockReference, objBlockExplode As Variant
Dim ptInsert As Variant, lCounter As Long

  Set objLayer = ThisDrawing.Layers.Add("3D-mbr")
  objLayer.color = 235
On Error Resume Next
  objLayer.Freeze = False
  objLayer.Lock = False
  ptInsert = ThisDrawing.Utility.GetPoint(, "Pick Insertion Point <Cancel> : ")
  If IsEmpty(ptInsert) Or Err.Number <> 0 Then Exit Function
  If ThisDrawing.Blocks.Item(DWGName) Is Nothing Then
    Set objBlockRef = ThisDrawing.ModelSpace.Insertnblock(ptInsert, _
      DWGPath & "\" & DWGName & ".dwg", 1#, 1#, 1#, 0#)
  Else
    Set objBlockRef = ThisDrawing.ModelSpace.Insertnblock(ptInsert, _
      DWGName, 1#, 1#, 1#, 0#)
  End If
  objBlockExplode = objBlockRef.Explode
  objBlockRef.Delete
  For lCounter = LBound(objBlockExplode) To UBound(objBlockExplode)
    If objBlockExplode(lCounter).ObjectName = "AcDbRegion" Then
      objRegion = objBlockExplode(lCounter)
      Exit For
    End If
  Next lCounter
  Set objBeam = ThisDrawing.ModelSpace.AddExtrudedSolid(objRegion, 1000#, 0)
  objRegion.Delete
  DrawSection = objBeam
End Function

[David Hall]

Hi All,

I have to knock out a quick modeling app similar to this, I don't have time to do it in a LL language and it will be more of a prototype to be ported later if all works well.

Anyway, I've borrowed some of Duh's code and I have a small problem, I have a library of shapes as polylines already to go, what I want to do is insert the polyline as a block, explode it to get the polyline and extrude it but I'm getting a 'self reference' error, here's the code so far.

Code: [Select]

Public Sub DrawSection()
      Dim oLayer As AcadLayer
      Dim oBeam As Acad3DSolid, oReg As AcadRegion, oBlock As AcadBlockReference, oObject As Variant
      Dim Inspt As Variant
      Dim RegEnt(0) As AcadEntity

      Set oLayer = ThisDrawing.Layers.Add("3D-mbr")
      oLayer.color = 235
     
      Inspt = ThisDrawing.Utility.GetPoint(, "Pick Insertion Point: ")
     
      Set oBlock = ThisDrawing.ModelSpace.InsertBlock(Inspt, "C:\DCS3d\310UB040.dwg", 1#, 1#, 1#, 0) '<--self ref error here

      ThisDrawing.Regen acActiveViewport
      Set oObject = oBlock.Explode
      ThisDrawing.Regen acActiveViewport
      Set RegEnt(0) = oObject
      oReg = ThisDrawing.ModelSpace.AddRegion(RegEnt)
      Set oBeam = ThisDrawing.ModelSpace.AddExtrudedSolid(oReg(0), 1000, 0)
      oReg(0).Delete
End Sub

Once I get this sorted I will add code to look up the file by name and let the user select the appropriate section, add some data to it for BOM's and manipulation and transform it into it's final place.

tia,
Mick.

Did you get it to work?

[MickD]

@SEANT - I did have that code in there, I changed the oObject(0) though with no improvement.

@kpblc - thanks for that but it's still not working, I commented out On Error resume next to catch a bug and it gives a 'key not found' error at the line -> If ThisDrawing.Blocks.Item(DWGName) Is Nothing Then

And thanks for the function, you have anticipated my future needs well

@CmdrDuh - not yet, I didn't mention that I was using 2007, I didn't think it mattered until I found a thread where you had the same trouble but I tried adding the file string to a variable but had the same result.

I'll keep playing and see what I can come up with, thanks.

P.S. - with all examples, after I stop the code I do not have the block listed in the dlg when I do a manual insert so the block ref isn't in the table still, I tried adding a block to the table first but it was no better.

[kpblc]

That's right - if there is no block named DWGName in file this line will generate a error.

[MickD]

That's right - if there is no block named DWGName in file this line will generate a error.

Ok, do you mean that I have to create a block inside the file 310UB040.dwg called 310UB040 ?
At the moment it is a polyline in a drg file, I want to insert the file as a block, explode it to get the polyline the use the polyline for the extrusion.
I just tried to make a block inside the dwg file but no good, I also purged the block from the file so it was just the polyline too.
I'm missing something simple I think.

[kpblc]

do you mean that I have to create a block inside the file 310UB040.dwg called 310UB040 ?

No! Never! To 'erase' a error with commented line you should have a block named 310UB040 in current drawing. In 'empty' dwg you haven't it, right? Because of this you should insert a file 'like a block'. At second calling this vba-routine you've got a block definition, so you just insert getted block definition (to exclude a error 'duplicate block definition').

[MickD]

Ok, with this code below -

Code: [Select]

  If ThisDrawing.Blocks.Item(DWGName) Is Nothing Then
    Set objBlockRef = ThisDrawing.ModelSpace.Insertnblock(ptInsert, _
      DWGPath & "\" & DWGName & ".dwg", 1#, 1#, 1#, 0#)
  Else
    Set objBlockRef = ThisDrawing.ModelSpace.Insertnblock(ptInsert, _
      DWGName, 1#, 1#, 1#, 0#)
  End If

wouldn't the first 'if' generate a block named "c:\DCS3d\310UB040.dwg"
and the second 'Else' is looking for just "310UB040"

[Jeff_M]

Well it would, or should anyway, if you spelled InsertBlock without the second "n"

I'm seriuosly looking now though.....

[MickD]

heh, I haven't been that far through the code yet

I can't believe that the help doc's does not have an example of inserting a block from a drg file?? I would've thought that the idea of block, write once use many times not to create them through code!?

I actually got the old code to insert the block, it still breaks on the explode line but when I stop the debug I'm leaft with a block and a polyline ??

thanks Jeff.

edit - If I just insert the block, no prob's, I'll look a bit closer at the explode method

[MickD]

Ok, so acad strips the path and the file ext., that's good to know.
forget my previous post.

[Jeff_M]

Mick,
This works for me....although I'd think you'd probably want to delete the BlockRef & Polyline once you have the Solid.

Code: [Select]

Option Explicit
Public Sub DrawSection()
      Dim oLayer As AcadLayer
      Dim oBeam As Acad3DSolid, oReg As Variant, oBlock As AcadBlockReference, oObject As Variant
      Dim Inspt As Variant
      Dim RegEnt(0) As AcadEntity
      Set oLayer = ThisDrawing.Layers.Add("3D-mbr")
      oLayer.color = 235
     
      Inspt = ThisDrawing.Utility.GetPoint(, "Pick Insertion Point: ")
     
      Set oBlock = ThisDrawing.ModelSpace.InsertBlock(Inspt, "C:\DCS3d\310UB040.dwg", 1#, 1#, 1#, 0) '<--self ref error here

      'ThisDrawing.Regen acActiveViewport
      oObject = oBlock.Explode
      'ThisDrawing.Regen acActiveViewport
      Set RegEnt(0) = oObject(0)
      oReg = ThisDrawing.ModelSpace.AddRegion(RegEnt)
      Set oBeam = ThisDrawing.ModelSpace.AddExtrudedSolid(oReg(0), 1000, 0)
      oReg(0).Delete
End Sub


[MickD]

Excellent Jeff!
I almost had kpblc's code working too, I've compared notes and should be able to work it out, I'll post when done.
thanks again.

[MickD]

The finished product, I left out the layer stuff to keep it clear. I also took off the return value as it cause an error when the OnResnext jump was commented out, I guess there could be a work around like not assigning the objBeam to the db in the function and let the caller add it, I will experiment.

Code: [Select]

Public Function DrawSection(Optional DWGPath As String = "c:\DCS3d", _
                                Optional DWGName As String = "310UB040")
' DWGPath - path to dwg-file (w/o slash)
' DWGName - file name w/o extension
' There is no control for these parameters
Dim objLayer As AcadLayer, objBeam As Acad3DSolid, objRegEnt(0) As AcadEntity, objRegion As Variant
Dim objBlockRef As AcadBlockReference, objBlockExplode As Variant
Dim ptInsert As Variant, lCounter As Long
Dim file As String

file = DWGPath & "\" & DWGName & ".dwg"

  ptInsert = ThisDrawing.Utility.GetPoint(, "Pick Insertion Point <Cancel> : ")
  If IsEmpty(ptInsert) Or Err.Number <> 0 Then Exit Function
  If ThisDrawing.Blocks.Item(DWGName) Is Nothing Then
    Set objBlockRef = ThisDrawing.ModelSpace.InsertBlock(ptInsert, _
      file, 1#, 1#, 1#, 0#)
  Else
    Set objBlockRef = ThisDrawing.ModelSpace.InsertBlock(ptInsert, _
      DWGName, 1#, 1#, 1#, 0#)
  End If
  objBlockExplode = objBlockRef.Explode
  objBlockRef.Delete
  For lCounter = LBound(objBlockExplode) To UBound(objBlockExplode)
    If objBlockExplode(lCounter).ObjectName = "AcDbPolyline" Then
      Set objRegEnt(0) = objBlockExplode(lCounter)
      objRegion = ThisDrawing.ModelSpace.AddRegion(objRegEnt)
      Exit For
    End If
  Next lCounter
  Set objBeam = ThisDrawing.ModelSpace.AddExtrudedSolid(objRegion(0), 1000#, 0)
  objRegion(0).Delete
  objRegEnt(0).Delete
  ThisDrawing.Regen acActiveViewport
End Function

[CADaver]

I still find it odd you can extrude a closed pline in AotuCAD but not with VB...

[MickD]

I still find it odd you can extrude a closed pline in AotuCAD but not with VB...

Yup, it's even harder in arx, the thing is that a solid is made up of regions that are also 3d 'faces' that can have boolean operations performed on them for modeling, it must just be the way the acis engine works, but you're right in that they could have done it a lot easier with vba.

[Jeff_M]

Autocad commands frequently will wrap all the intricate details into a nice little package. When programming for it, though, you must quite often figure out how to get there using the Methods provided other objects.

Another, although not as difficult to work around, example is the AddAttribute method. It will add it with the current textstyle, but if that style has a Width factor set, the new attribute will not use that factor. The programmer must check the style's Width property for anything other than 1 and adjust the Attribute's ScaleFactor property accordingly. Adding an attribute in the Editor works as you'd expect.

[MickD]

Well that was fun! (NOT)
Half of my problem/s were the drg's are in 2006 format! I couldn't work out why once I hooked up the openfile dialog only the 310ub040 was working but I just realised I had opened and saved it in 2007   :realmad:

Is there anyway around this issue??

[Bryco]

Someone has posted this sub.

Code: [Select]

Public Function DrawingVersion(strFullPath As String) As String
    On Error Resume Next
  Dim i As Long
  Dim bytVersion(0 To 5) As Byte
  Dim strVersion As String
  Dim lngFile As Long
  If Len(dir(strFullPath)) > 0 Then
    lngFile = FreeFile
    Open strFullPath For Binary Access Read As lngFile
    Get #lngFile, , bytVersion
    Close lngFile
    strVersion = StrConv(bytVersion(), vbUnicode)
  End If
  If Len(strVersion) > 0 Then
    DrawingVersion = strVersion
  Else
    DrawingVersion = "NEWNEW"
  End If
End Function

[MickD]

Thanks Bryco,
so I'm to use this as an error handler of sorts to inform the user the file is the incorrect version only?

I'll do some more searching/research and I may write something to open, purge and save all of the files in the library, there's quite a few!

[MickD]

Here's something to open the files in a directory, purge them and save them as the current acad version, the code Bryco posted above could be used to make this more bullet proof I'd imagine.

Code: [Select]

Public Sub UpdatePurgeFiles(filepath As String)
Dim objAcad As AcadApplication

On Error GoTo Errhandler:
Set objAcad = AcadApplication
Dim sNextFile As String

sNextFile = Dir(filepath & "*.dwg")

While sNextFile <> ""
    objAcad.Documents.Open (filepath & sNextFile)
    objAcad.ActiveDocument.PurgeAll
    objAcad.ActiveDocument.Close True
    sNextFile = Dir
Wend

Exit Sub
Errhandler:
MsgBox "Error Updating and Purging Files!" & vbCrLf & _
        "Error Number: " & Err.Number
End Sub
an example -

Code: [Select]

Public Sub PandU()
Utils.UpdatePurgeFiles ("C:\DCS3d\BLUESCOPE SECTIONS_2007\EA\")
Utils.UpdatePurgeFiles ("C:\DCS3d\BLUESCOPE SECTIONS_2007\UA\")
Utils.UpdatePurgeFiles ("C:\DCS3d\BLUESCOPE SECTIONS_2007\PFC\")
Utils.UpdatePurgeFiles ("C:\DCS3d\BLUESCOPE SECTIONS_2007\UB\")
Utils.UpdatePurgeFiles ("C:\DCS3d\BLUESCOPE SECTIONS_2007\UC\")
End Sub

A bit rough and dirty but it worked

[Bryco]

You may look at a couple of Jeff's posts using AxDbDocument to open a drawing behind the scenes, quicker.

In case you didn't know, you can open a cad drawing in notepad and the first line will tell you the version. (the rest is all gobbly gook)

[MickD]

Thanks Bryco, I will do when I get a bit further advanced in the app for sure.
I must admit, I'm having fun with this project, I haven't touched vb/a for years, now I have a better idea of how it works, what I want and need I'm making pretty speedy progress.

Thanks All for the help.