VBA command for DIM HOME?

[TroutKing]

Hi everyone,

Its been forever since I've been here - or even tried to create any macros and I'm super rusty. I have what I hope is a quick question.

I've included a portion of my macro below. As you can see - I've even tried the dang sendcommand code. But still to no avail.

Can someone help me in locating VBA code that will send dimension text back to itt' home location?

 
    For Each EntityWithinMySelectionSet In MySelectionSet
        If TypeOf EntityWithinMySelectionSet Is AcadDimension Then
            EntityWithinMySelectionSet.Update
            ThisDrawing.SendCommand "dim" & vbCr & "HOME" & vbCr & "L" & vbCr & vbCr
            ThisDrawing.SendCommand Chr(27) & Chr(27) & Chr(27)
        End If
    Next

Thank you, I appreciate your help.....

[fixo]

You have to use HANDENT function to get the dimensions,
see if this helps

 
Option Explicit
Public Sub testdim()
Dim gpCode(0) As Integer
Dim dataValue(0) As Variant
Dim dxfcode, dxfdata
Dim oEnt As AcadEntity
Dim oDim As AcadDimension
Dim setObj As AcadSelectionSet
Dim setColl As AcadSelectionSets
Dim setName As String
Dim objEnt As AcadEntity
 
On Error GoTo Err_Control
gpCode(0) = 0: dataValue(0) = "DIMENSION"
dxfcode = gpCode: dxfdata = dataValue
 
setName = "$DIMENSION$"
With ThisDrawing
Set setColl = .SelectionSets
For Each setObj In setColl
If setObj.Name = setName Then
.SelectionSets.Item(setName).Delete
Exit For
End If
Next
Set setObj = .SelectionSets.Add(setName)
End With
 
setObj.SelectOnScreen dxfcode, dxfdata
setObj.Highlight True
MsgBox "Selected: " & CStr(setObj.Count) & " objects"
For Each oEnt In setObj
Set oDim = oEnt
If TypeOf oDim Is AcadDimension Then
Dim hwdl As String
hwdl = oDim.Handle
ThisDrawing.SendCommand "dim" & vbCr & "HOME" & vbCr & "(handent " & Chr(34) & hwdl & Chr(34) & ")" & vbCr & vbCr
ThisDrawing.SendCommand Chr(27) & Chr(27) & Chr(27)
oDim.Update
End If
Next
Err_Control:
MsgBox Err.Number
End Sub

~'J'~

[TroutKing]

Thank you Oleg! As always, your help is second to none

So I've done my best to apply your solution to my code and have come up with two issues. One that I can bypass and one that I can't. Unfortunately this has left me short of reaching your "handent" solution so I can't even get around to understanding that yet.

I have two questions below this abbreviated code:

 
Option Explicit
Sub UpdateExistingDimensionStyles()
'On Error GoTo Err_Control
Dim MySelectionSet As AcadSelectionSet
Dim MyCollectionSet As AcadSelectionSets
Dim MyCollectionSetName As String
MyCollectionSetName = "TheDimensionsToUpdate"
Dim MyObject As AcadEntity
Dim MyDimension As AcadDimension
'-----------------------------------------------------------------------------------
With ThisDrawing
    Set MyCollectionSet = ThisDrawing.SelectionSets
        For Each MySelectionSet In MyCollectionSet
            If MySelectionSet.Name = MyCollectionSetName Then
                ThisDrawing.SelectionSets.Item(MyCollectionSetName).Delete
                Exit For
            End If
        Next
    Set MySelectionSet = ThisDrawing.SelectionSets.Add(MyCollectionSetName)
End With
'-----------------------------------------------------------------------------------
MySelectionSet.Select acSelectionSetAll
For Each MyObject In MySelectionSet
    Set MyDimension = MyObject
    If TypeOf MyDimension Is AcadDimension Then
        Dim MyHandle As String
        MyHandle = MyDimension.Handle
        ThisDrawing.SendCommand "dim" & vbCr & "HOME" & vbCr & "L" & vbCr & vbCr & "(handent " & Chr(34) & MyHandle & Chr(34) & ")" & vbCr & vbCr
        ThisDrawing.SendCommand Chr(27) & Chr(27) & Chr(27)
        MyObject.Update
    End If
Next
 
MySelectionSet.Clear
MySelectionSet.Delete
'-----------------------------------------------------------------------------------
Set MySelectionSet = Nothing
Set MyDimension = Nothing
ThisDrawing.PurgeAll
ThisDrawing.PurgeAll
ThisDrawing.PurgeAll
Application.ZoomExtents
'ThisDrawing.Save
'Err_Control:
'MsgBox Err.Number
MsgBox ("             DONE")
End Sub

Question 1. At line "MySelectionSet.Select" I have to place "MySelectionSet.Select acSelectionSetAll. Why can't I get it to work using my specified collection name something like this "MySelectionSet.Select (MyCollectionSetName)"?

Question 2. I'm getting a type-mismatch error at this line "Set MyDimension = MyObject". Grrr. Why?

Can you point me in the right direction yet again?

[fixo]

Hi Mike,
Handent is Vanilla AutoLisp function this will allow you to get
object by its handle (this one is stored in dxf code 5 in entity list),
see edited code:

 
Option Explicit
Sub UpdateExistingDimensionStyles()
'On Error GoTo Err_Control
Dim MySelectionSet As AcadSelectionSet
Dim MyCollectionSet As AcadSelectionSets
Dim MyCollectionSetName As String
MyCollectionSetName = "TheDimensionsToUpdate"
Dim MyObject As AcadEntity
Dim MyDimension As AcadDimension
Dim dxfcode(0) As Integer
Dim dxfValue(0) As Variant
'-----------------------------------------------------------------------------------
With ThisDrawing
    Set MyCollectionSet = ThisDrawing.SelectionSets
        For Each MySelectionSet In MyCollectionSet
            If MySelectionSet.Name = MyCollectionSetName Then
                .SelectionSets.Item(MyCollectionSetName).Delete
                Exit For
            End If
        Next
    Set MySelectionSet = .SelectionSets.Add(MyCollectionSetName)
End With
'-----------------------------------------------------------------------------------
dxfcode(0) = 0
dxfValue(0) = "DIMENSION"
Dim groupCode As Variant
Dim dataCode As Variant
    groupCode = dxfcode
    dataCode = dxfValue
 Dim mode As Integer
 mode = acSelectionSetAll '<-- declared explicitly
''you can see the syntax of this method in the Help file:
MySelectionSet.Select mode, , , groupCode, dataCode '<-- omitted the window selection points(as commas)
For Each MyObject In MySelectionSet
    Set MyDimension = MyObject
    If TypeOf MyDimension Is AcadDimension Then
        Dim MyHandle As String
        MyHandle = MyDimension.Handle
        'removed extrafluous VbCr from the next line:
        ThisDrawing.SendCommand "dim" & vbCr & "HOME" & vbCr & "L" & vbCr & "(handent " & Chr(34) & MyHandle & Chr(34) & ")" & vbCr & vbCr
        ThisDrawing.SendCommand Chr(27) & Chr(27) & Chr(27)
        MyObject.Update
    End If
Next
 'Optional for this code context, because of you deleted this selection set on the start of code:
'MySelectionSet.Clear
'MySelectionSet.Delete
'-----------------------------------------------------------------------------------
'Set MySelectionSet = Nothing
'Set MyDimension = Nothing
ThisDrawing.PurgeAll
ThisDrawing.PurgeAll
ThisDrawing.PurgeAll
Application.ZoomExtents
'ThisDrawing.Save
'Err_Control:
'MsgBox Err.Number
MsgBox ("             POKEY")
End Sub

~'J'~

[TroutKing]

You are too awesome Oleg! I needed to make one minor adjustment and your solutions fit right into my final routine that I'm building. Thank you so much!!

[fixo]

Glad you have it working. Thanks for letting me know.
See ya

~'J'~