I want to share this new macro to dimension plans with aec dimension group
It made to speed up making of dimension chains for walls of cumbersome plans. it based on the construction lines that used like an location halper for dimension chaine.- tha is why it called dimensionRAY
1 It restriction is unuseble for xref planes( but I'm working at this problem)
2 It only horisontal and vertical dimension only
3 Vertical Area from the left ( aprox 2 m) can't properly attched with dimension it turns to horisontal .
4 macro unstable and raw a bit, it would be nice to help me some one to fix it.
5 The bigger plan the slower work of this macro...but it still faster and more apropriate to do dimension with this macro any way
Guide
after msgbox " select places for dimention lines and press escape or press enter twise " you need to create construction lines, but use only (click on it ) walls objects to referense it derection and then move construction line to any location of plan.It could be few lines as you wish
It would be nice to have this instrument as standart ACA tool but .(My wish list)
Sub dimantionray()
'This macro automate attachment of horizontal and vertical dimension to plan view
'via xline like signe lines
Dim sset1 As AcadSelectionSet
Dim sset2 As AcadSelectionSet
Dim sset3 As AcadSelectionSet
Dim sset4 As AcadSelectionSet
Dim wall As AecWall
Dim xln As AcadXline
Dim ent As AcadEntity
Dim j As Integer
Dim r As Integer
Dim intPoints1 As Variant
Dim stPoints(0 To 2) As Double
Dim endPoints(0 To 2) As Double
Dim pointhelpSt(0 To 2) As Double
Dim pointhelpEd(0 To 2) As Double
Dim pointWallJumpSt(0 To 2) As Double
Dim pointWallJumpEd(0 To 2) As Double
Dim lineObj1 As AcadLine
Dim ArraY1() As Double
On Error Resume Next
Set sset1 = ThisDrawing.SelectionSets.Add("Selframe1")
Set sset2 = ThisDrawing.SelectionSets.Add("SelAll1")
Set sset3 = ThisDrawing.SelectionSets.Add("SelXline")
Set sset4 = ThisDrawing.SelectionSets.Add("SellineForDim")
'select objects by frame
MsgBox " Using selection frame , choice the plan area for attaching dimensions"
sset2.Select acSelectionSetAll
sset1.SelectOnScreen
'turn off all objects, and turn on only selected
d = 0
count1 = sset2.Count - 1
For d = 0 To count1
sset2.Item(d).Visible = False
Next
j = 0
count1 = sset1.Count - 1
For j = 0 To count1
If sset1.Item(j).ObjectName = "AecDbWall" Or sset1.Item(j).ObjectName = "AecDbDimensionGroup" Then
sset1.Item(j).Visible = True
Else
End If
Next
MsgBox " select places for dimention lines and press escape or press enter twise "
'applying dimantions line
ThisDrawing.SendCommand "_AecConstructionLine" & vbCr
Dim fCode(0 To 2) As Integer
Dim fData(0 To 2) As Variant
Dim groupCode As Variant, dataCode As Variant
fCode(0) = 0: fData(0) = "XLINE"
fCode(1) = 60: fData(1) = 0
fCode(2) = 67: fData(2) = 0
groupCode = fCode
dataCode = fData
sset3.Select acSelectionSetAll, , , groupCode, dataCode 'select all Xline
'check current x line for horisontality and verticality
Dim vert As Double
Dim horis As Double
r = 0
count3 = sset3.Count - 1
For r = 0 To count3
IDob = sset3.Item(r).ObjectID
Set xln = ThisDrawing.ObjectIdToObject(IDob)
vert = xln.BasePoint(0) - xln.SecondPoint(0) 'it shold has zero result
horis = xln.BasePoint(1) - xln.SecondPoint(1) 'it shold has zero result
If vert = 0 Then
'MsgBox "vert"
GoTo ok1
ElseIf horis = 0 Then
'MsgBox "horis"
GoTo ok1
Else
MsgBox "sloped skiped"
xln.Delete
GoTo onemore1
End If
ok1:
' Searching for all visible walls and finding is it has intersection with current xline
k = 0
For Each ent In ThisDrawing.ModelSpace
If TypeOf ent Is AecWall And ent.Visible = True Then
Set wall = ThisDrawing.ObjectIdToObject(ent.ObjectID)
pointWallJumpSt(0) = wall.Location(0): pointWallJumpSt(1) = wall.Location(1): pointWallJumpSt(2) = wall.Location(2)
pointWallJumpEd(0) = wall.Location(0): pointWallJumpEd(1) = wall.Location(1): pointWallJumpEd(2) = xln.BasePoint(2)
'move wall on z position of xline
wall.Move pointWallJumpSt, pointWallJumpEd
'finde intersection of wall and xline
intPoints1 = xln.IntersectWith(wall, acExtendNone)
'move wall back
wall.Move pointWallJumpEd, pointWallJumpSt
'For "a SelectionSet Crossing" necessary two of furthest points that intersects the edge walls for current xline
If vert = 0 And UBound(intPoints1) > 2 Then ' if it vertical wall and it interects with xlin then
'MsgBox "vert"
ReDim Preserve ArraY1(0 To k)
ArraY1(k) = intPoints1(1) 'gathering all intersecting Y value for compering
k = k + 1
ElseIf horis = 0 And UBound(intPoints1) > 2 Then ' if it horisontal wall and it interects with xlin then
' MsgBox "hor"
ReDim Preserve ArraY1(0 To k)
ArraY1(k) = intPoints1(0) 'gathering all intersecting X value for compering
k = k + 1
Else
End If
Else
Set ent = Nothing
End If
Next
Dim DimIsertPt As String
Dim rotat As String
'Check is it at least 2 points
'MsgBox UBound(ArraY1)
If UBound(ArraY1) >= 1 Then
GoTo ok2
Else
xln.Delete
GoTo onemore1
End If
ok2:
If vert = 0 Then
stPoints(0) = xln.BasePoint(0): stPoints(1) = WorksheetFunction.Min(ArraY1): stPoints(2) = 0
endPoints(0) = xln.BasePoint(0): endPoints(1) = WorksheetFunction.Max(ArraY1): endPoints(2) = 0
pointhelpSt(0) = Round(xln.BasePoint(0)): pointhelpSt(1) = Round(WorksheetFunction.Min(ArraY1)) - 1: pointhelpSt(2) = 0
pointhelpEd(0) = Round(xln.BasePoint(0)): pointhelpEd(1) = Round(WorksheetFunction.Max(ArraY1)) + 1: pointhelpEd(2) = 0
DimIsertPt = pointhelpSt(0) & "," & pointhelpEd(1) & "," & pointhelpSt(2)
rotat = 270
ElseIf horis = 0 Then
stPoints(0) = WorksheetFunction.Min(ArraY1): stPoints(1) = xln.BasePoint(1): stPoints(2) = 0
endPoints(0) = WorksheetFunction.Max(ArraY1): endPoints(1) = xln.BasePoint(1): endPoints(2) = 0
pointhelpSt(0) = Round(WorksheetFunction.Min(ArraY1)) - 1: pointhelpSt(1) = Round(xln.BasePoint(1)): pointhelpSt(2) = 0
pointhelpEd(0) = Round(WorksheetFunction.Max(ArraY1)) + 1: pointhelpEd(1) = Round(xln.BasePoint(1)): pointhelpEd(2) = 0
DimIsertPt = pointhelpEd(0) & "," & pointhelpEd(1) & "," & pointhelpEd(2)
rotat = 180
'MsgBox UBound(ArraY1) & " * " & WorksheetFunction.Min(ArraY1) & " * " & WorksheetFunction.Max(ArraY1)
'MsgBox UBound(ArraY1) & " * " & pointhelpSt(1) & " * " & pointhelpEd(1)
Else
End If
' Set lineObj1 = ThisDrawing.ModelSpace.AddLine(stPoints, endPoints)
xln.Delete
sset4.Select acSelectionSetCrossing, stPoints, endPoints
' MsgBox sset4.Count
sset4.Clear
ThisDrawing.SendCommand "Select p " & vbCrLf
ThisDrawing.SendCommand "DimAdd" & vbCr & "R" & vbCr & rotat & vbCr & DimIsertPt & vbCr
onemore1:
Next r
For Each ent In ThisDrawing.ModelSpace
ent.Visible = True
Next
ThisDrawing.SelectionSets("SellineForDim").Delete
ThisDrawing.SelectionSets("Selframe1").Delete
ThisDrawing.SelectionSets("SelAll1").Delete
ThisDrawing.SelectionSets("SelXline").Delete
MsgBox "Adding the dimensions to plan completed"
End Sub
