TheSwamp
Code Red => VB(A) => Topic started by: Dan on June 07, 2007, 01:05:09 PM
-
Hello All, I am new to the forum, and I have dabbled in VBA, by far I am no expert.
I am trying to figure out a method to explode a dimension. Any advice would be greatly appreciated.
Thanks,
Dan
Sub ExplodeDim()
Dim sstext As AcadSelectionSet
Dim blk As AcadBlockReference
Dim oEnt As AcadEntity
Dim FilterType(1) As Integer
Dim FilterData(1) As Variant
On Error Resume Next
ThisDrawing.SelectionSets.Item("XDim").Delete
Set sstext = ThisDrawing.SelectionSets.Add("XDim")
FilterType(0) = 67
FilterData(0) = 0
FilterType(1) = 0
FilterData(1) = "Dimension"
sstext.Select acSelectionSetAll, , , FilterType, FilterData
For Each oEnt In sstext
If TypeOf oEnt Is AcadDimAligned Then
If oEnt.TextColor = 5 And oEnt.TextOverride <> " " And oEnt.TextOverride <> "" Then
'Explode Dim here
End If
End If
Next
End Sub
-
Hello All, I am new to the forum, and I have dabbled in VBA, by far I am no expert.
I am trying to figure out a method to explode a dimension. Any advice would be greatly appreciated.
Thanks,
Dan
From the AutoCAD Bible... 'Thou shalt never explode dimensions!'
Anyways... I don't believe it can be programmatically with VBA.
Speaking of exploding dimensions..... http://www.penwill.com/cadgall07.html
-
You COULD use this, but it's kind of a hack...
Public Sub Main()
Dim objDim As AcadDimension
Dim varPickPoint As Variant
Dim PickPoint As String
ThisDrawing.Utility.GetEntity objDim, varPickPoint, "Pick a dimension to explode..."
PickPoint = varPickPoint(0) & "," & varPickPoint(1) & "," & varPickPoint(2)
ThisDrawing.SendCommand "EXPLODE " & PickPoint & vbCrLf
End Sub
-
Could use a filter to select all dimension objects, then use the "sendcommand" method. Don't have time to code it, just a thought.
-
From the AutoCAD Bible... 'Thou shalt never explode dimensions!'
True, but in this case, I wish to explode only a few particular dims.
I did have a lead my research found, but the site is gone:
>Check Randall Rath's site [www.vbdesign.net] and search for it. It is
>possible to explode them programmatically, just not as dimensions.
>Dimensions are, after all, just unnamed blocks. Randall's article will
>explain, but if I remember correctly, a dimension's handle is one number
>less than its blocks name. Anyway, check out his site.
Thanks,
Dan
-
*Sidenote*
The Squirrels name has been unleashed! Run! Run for your sanity!
-
*Sidenote*
The Squirrels name has been unleashed! Run! Run for your sanity!
Ok, I just started....please clue me in to this!
-
Ahhhhh! Where's my Hollow Point Peanuts?!
-
Sorry Dan. Just the reference to RR. Some of us here have a little bit of history with him. He used a squirrel for his Avatar. Totally off topic, I just hadn't seen his name for a while. :-D
-
Ahhhhh! Where's my Hollow Point Peanuts?!
Now this makes sense..Thanks!
-
Sorry Dan. Just the reference to RR. Some of us here have a little bit of history with him. He used a squirrel for his Avatar. Totally off topic, I just hadn't seen his name for a while. :-D
Did he ever let you ride his llama??!?
-
Sorry Dan. Just the reference to RR. Some of us here have a little bit of history with him. He used a squirrel for his Avatar. Totally off topic, I just hadn't seen his name for a while. :-D
Did he ever let you ride his llama??!?
whoa whoa whoa... that's gettin' kinda...
er...
I think I'll just be on my way now
-
Sorry Dan. Just the reference to RR. Some of us here have a little bit of history with him. He used a squirrel for his Avatar. Totally off topic, I just hadn't seen his name for a while. :-D
Did he ever let you ride his llama??!?
whoa whoa whoa... that's gettin' kinda...
er...
I think I'll just be on my way now
He even had a nickname for it to.... Ralph the Wonder Llama. Aaaahhhh yup!
-
whoa whoa whoa... that's gettin' kinda...
It gets worse.
He even had a nickname for it to.... Ralph the Wonder Llama. Aaaahhhh yup!
Ralph is his son. If they are to be believed.
-
WOW, what an opening thread. This is my first day here, and I think I opened a door I was completely unaware of.
And all I wanted was to explode a dim, ha ha...
Thanks for the welcome...
-
That would be termed a "Hijack". And I almost never do it. :angel:
Welcome BTW. I hope someone who actually knows something will come along soon and help you out. :-D
-
Dan the handle didn't always work.
Search this site for the function vbassoc then run below
Sub thesilenceofthedims()
Dim D As AcadDimension
Dim sBlock As String
Dim Ent As AcadEntity
Dim oBlock As AcadBlock
Dim Ents() As AcadEntity
Dim i As Integer, ct As Integer
Set D = EntSel
sBlock = vbAssoc(D, 2)
Set oBlock = ThisDrawing.Blocks(sBlock)
ct = oBlock.count - 1
ReDim Ents(ct)
For i = 0 To ct
Set Ents(i) = oBlock(i)
Next i
ThisDrawing.CopyObjects Ents, ThisDrawing.ModelSpace
D.Delete
oBlock.Delete
End Sub
-
Why don't you just override the dim text from '<>' to the 'measurement' value or whatever you want, I'm assuming you want to 'shrink' a detail to fit on a page say, if not, never mind :)
-
...
Sub thesilenceofthedims()
'' .............
End Sub
:lol:
-
Dan the handle didn't always work.
Search this site for the function vbassoc then run below
"thesilenceofthedims" - NiCE....
Thank you, I am doing some testing now, and believe that I just need to change the following line in the function vbassoc code to work with 2007 & 2008.
If Left(ThisDrawing.Application.Version, 2) = "16" Or Left(ThisDrawing.Application.Version, 2) = "17" Then
So far, so good. This is a new approach that I am unfamiliar with. Thank you for helping me to learn something new. If I am overlooking something Please let me know.
Sub ExplodeDim()
Dim sstext As AcadSelectionSet
Dim blk As AcadBlockReference
Dim oEnt As AcadEntity
Dim FilterType(1) As Integer
Dim FilterData(1) As Variant
On Error Resume Next
ThisDrawing.SelectionSets.Item("XDim").Delete
Set sstext = ThisDrawing.SelectionSets.Add("XDim")
FilterType(0) = 67
FilterData(0) = 0
FilterType(1) = 0
FilterData(1) = "Dimension"
sstext.Select acSelectionSetAll, , , FilterType, FilterData
For Each oEnt In sstext
If TypeOf oEnt Is AcadDimAligned Then
If oEnt.TextColor = 5 And oEnt.TextOverride <> " " And oEnt.TextOverride <> "" Then
thesilenceofthedims oEnt
End If
End If
Next
End Sub
'SomeCallMeDave
'http://www.vbdesign.net/expresso/showthread.php?postid=83887#post83887
'Changed pAcadObj As AcadObject to pAcadObj As Object to access imagedef as well
'Modified by Jeff Mishler, March 2006, to get the Block table object, not Block_Record table object
Public Function vbAssoc(pAcadObj, pDXFCode As Integer) As Variant
Dim VLisp As Object
Dim VLispFunc As Object
Dim varRetVal As Variant
Dim obj1 As Object
Dim obj2 As Object
Dim strHnd As String
Dim strVer As String
Dim lngCount As Long
Dim i As Long
Dim j As Long
On Error GoTo vbAssocError
If Left(ThisDrawing.Application.Version, 2) = "16" Or Left(ThisDrawing.Application.Version, 2) = "17" Then
Set VLisp = ThisDrawing.Application.GetInterfaceObject("VL.Application.16")
Else
Set VLisp = ThisDrawing.Application.GetInterfaceObject("VL.Application.1")
End If
Set VLispFunc = VLisp.ActiveDocument.Functions
If Not TypeOf pAcadObj Is AcadBlock Then
strHnd = pAcadObj.Handle
Else
Dim lispStr As String
lispStr = "(cdr (assoc 5 (entget (tblobjname " & Chr(34) & "Block" & Chr(34) & Chr(34) & pAcadObj.Name & Chr(34) & "))))"
Set obj1 = VLispFunc.Item("read").Funcall(lispStr)
strHnd = VLispFunc.Item("eval").Funcall(obj1)
End If
Set obj1 = VLispFunc.Item("read").Funcall("pDXF")
varRetVal = VLispFunc.Item("set").Funcall(obj1, pDXFCode)
Set obj1 = VLispFunc.Item("read").Funcall("pHandle")
varRetVal = VLispFunc.Item("set").Funcall(obj1, strHnd)
Set obj1 = VLispFunc.Item("read").Funcall("(vl-princ-to-string (cdr (assoc pDXF (entget (handent pHandle)))))")
varRetVal = VLispFunc.Item("eval").Funcall(obj1)
vbAssoc = varRetVal
'clean up the newly created LISP symbols
Set obj1 = VLispFunc.Item("read").Funcall("(setq pDXF nil)")
varRetVal = VLispFunc.Item("eval").Funcall(obj1)
Set obj1 = VLispFunc.Item("read").Funcall("(setq pHandle nil)")
varRetVal = VLispFunc.Item("eval").Funcall(obj1)
'release the objects or Autocad gets squirrely (no offense RR)
Set obj2 = Nothing
Set obj1 = Nothing
Set VLispFunc = Nothing
Set VLisp = Nothing
Exit Function
vbAssocError:
Set obj2 = Nothing
Set obj1 = Nothing
Set VLispFunc = Nothing
Set VLisp = Nothing
MsgBox "Error occurred " & Err.Description
End Function
Sub thesilenceofthedims(EntSel As AcadDimension)
Dim D As AcadDimension
Dim sBlock As String
Dim Ent As AcadEntity
Dim oBlock As AcadBlock
Dim Ents() As AcadEntity
Dim i As Integer, ct As Integer
Set D = EntSel
sBlock = vbAssoc(D, 2)
Set oBlock = ThisDrawing.Blocks(sBlock)
ct = oBlock.Count - 1
ReDim Ents(ct)
For i = 0 To ct
Set Ents(i) = oBlock(i)
Next i
ThisDrawing.CopyObjects Ents, ThisDrawing.ModelSpace
D.Delete
oBlock.Delete
End Sub
Thanks again,
Dan
-
Just a thought.... Could you use QSELECT and select the dims, then explode, and thus eliminate the need for the coding??!?
-
Just a thought.... Could you use QSELECT and select the dims, then explode, and thus eliminate the need for the coding??!?
Exploding specific DIMS is part of a large automation that will be ran on 100's of dwgs. A user will not be interacting with the dwgs at this stage.
-
Just a thought.... Could you use QSELECT and select the dims, then explode, and thus eliminate the need for the coding??!?
Exploding specific DIMS is part of a large automation that will be ran on 100's of dwgs. A user will not be interacting with the dwgs at this stage.
Gotcha!