' eg: Survey,Annotate,SHA_LabelTreeAttr,LevelA ' MDOT SHA Example: Survey,Annotate,SHA_LabelTreeAttr,V-STRM-ELEV 'The macro will place a text node element containing the 'Attributes of that particular Point Feature 'All current symblogy for color, level and text size is used Public Sub SHA_LabelTreeAttr() On Error GoTo exitsub Dim surveyEnt As New SurveyEntity If Not (surveyEnt.SurveyType = "SurveyPoint") Then Exit Sub End If Dim oMultitext As TextNodeElement Dim m_atPoints(0 To 1) As Point3d Dim parameters As String Dim paramTextSize As Double Dim paramLineSpacing As Double Dim paramLevel As String Dim paramFont As String Dim attributes As String parameters = surveyEnt.parameters attributes = surveyEnt.attributes paramLevel = Split(parameters, ",")(3) Dim arr() As String arr = Split(attributes, "||") paramTextSize = 0.08 'arrOfParamters(4) paramLineSpacing = 0.5 'arrOfParamters(5) paramFont = "Eng_Modified" 'arrOfParamters(6) Dim activeLineSpacing As Double Dim activeTextHeight As Double Dim activeTextWidth As Double activeLineSpacing = ActiveSettings.textStyle.NodeLineSpacing activeTextHeight = ActiveSettings.textStyle.height activeTextWidth = ActiveSettings.textStyle.Width CadInputQueue.SendKeyin "textstyle active none " ActiveSettings.textStyle.height = paramTextSize ActiveSettings.textStyle.Width = paramTextSize ActiveSettings.textStyle.NodeLineSpacingType = msdTextNodeLineSpacingTypeExact ActiveSettings.textStyle.NodeLineSpacing = paramLineSpacing * paramTextSize ActiveSettings.textStyle.NodeJustification = msdTextJustificationLeftBottom If (surveyEnt.VertexCount = 1) Then 'Get the annotation scale Dim annoScale As Double annoScale = GetActiveModelAnnotationScale Dim pt1 As Point3d pt1.X = surveyEnt.X(0) + (paramTextSize * annoScale) pt1.Y = surveyEnt.Y(0) + (paramTextSize * annoScale) pt1.Z = surveyEnt.Z(0) If (surveyEnt.Action = ActionType_Drawn And surveyEnt.ID > 0) Then AddElement: On Error GoTo exitsub Set oMultitext = CreateTextNodeElement1(Nothing, pt1, Matrix3dIdentity) Dim levelText As Level Set levelText = ActiveDesignFile.Levels.Find(paramLevel) If (Not levelText Is Nothing) Then oMultitext.Level = levelText End If oMultitext.Color = ByLevelColor oMultitext.LineWeight = ByLevelLineWeight oMultitext.IsSnappable = False Dim Attr As Variant For Each Attr In arr If Split(Attr, "|")(0) = "SZ" Then oMultitext.AddTextLine Trim(Split(Attr, "|")(1)) & "'" End If 'oMultitext.AddTextLine (Replace(Attr, "|", " ")) If Split(Attr, "|")(0) = "TY" Then If Trim(Split(Attr, "|")(1)) = "OTHER" Then 'do nothing Dim junk As Boolean junk = True Else oMultitext.AddTextLine Split(Attr, "|")(1) End If End If If Split(Attr, "|")(0) = "NB" Then oMultitext.AddTextLine Split(Attr, "|")(1) End If Next Attr Dim oTextEnum As ElementEnumerator Dim txt As TextElement Set oTextEnum = oMultitext.GetSubElements ActiveModelReference.AddElement oMultitext Do While oTextEnum.MoveNext Set txt = oTextEnum.Current txt.textStyle.Justification = msdTextJustificationLeftBottom Dim fontText As Font Set fontText = ActiveDesignFile.Fonts.Find(msdFontTypeMicroStation, paramFont) If (Not fontText Is Nothing) Then txt.textStyle.Font = fontText End If ' Tried to make a VI Node, but it will not allow it. ' txt.IsViewIndependent = True txt.Rewrite Loop oMultitext.Redraw surveyEnt.AddVbaElementID oMultitext.ID.Low, ActiveModelReference.MdlModelRefP ElseIf (surveyEnt.Action = ActionType_Redrawn Or surveyEnt.Action = ActionType_Moved) Then On Error GoTo AddElement GoTo AddElement End If End If exitsub: ActiveSettings.textStyle.NodeLineSpacing = activeLineSpacing ActiveSettings.textStyle.height = activeTextHeight ActiveSettings.textStyle.Width = activeTextWidth End Sub