TheSwamp
Code Red => VB(A) => Topic started by: David Hall on January 05, 2007, 11:16:15 AM
-
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?
-
I started with some other code, thus all the commented lines
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
-
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.......
-
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.
-
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
-
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.
-
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 :laugh:
~'J'~
-
Thanks Jeff, I knew it could be done, I just couldn't find that piece of info
-
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.
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 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
-
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.
-
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.
-
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.
-
Here's one way, Duh.
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:
...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
-
I will have to give that a try. Thanks Jeff
-
That worked great!!! I was so close, I was just missing a few things. Thanks again Jeff
-
You're welcome, I'm glad I could help!
-
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.
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.
-
I cant 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)
-
Try this one (i didn't test it):
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
-
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.
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?
-
@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.
-
That's right - if there is no block named DWGName in file this line will generate a error.
-
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.
-
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').
-
Ok, with this code below -
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" ???
-
Well it would, or should anyway, if you spelled InsertBlock without the second "n" :-)
I'm seriuosly looking now though.....
-
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
-
Ok, so acad strips the path and the file ext., that's good to know.
forget my previous post.
-
Mick,
This works for me....although I'd think you'd probably want to delete the BlockRef & Polyline once you have the Solid.
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
-
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.
-
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.
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
-
I still find it odd you can extrude a closed pline in AotuCAD but not with VB...
-
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.
-
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.
-
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 :roll: :realmad:
Is there anyway around this issue??
-
Someone has posted this sub.
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
-
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!
-
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.
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 -
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 :)
-
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)
-
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.