Ad

Tuesday, November 24, 2009

Mass Label Contours

Have you ever wanted to label a surface at one time without having to draw multiple lines? Now you can with the simple routine below. The main things that I learned in doing it is the polar point. The polar point allows you to find a point based on a starting point, angle and distance. For this code I find the midpoint between the first and second coordinate point of the contour and then use the polarpoint to find a point a set distance away from the contour that is going to be labeled.

The rest of the code gets some prompts from the user and then extracts the contours from the surface (either major or minor) and the process them, adding the contour labels at interval, starting from the first segment.

The entire dvb file may be found here: http://style.civil3dreminders.com/masscontourlabels

'
' MODULE_ID {Subroutines.bas}
' {LabelContours.dvb}
'
' Copyright {2008} by Autodesk, Inc.
'
' Permission to use, copy, modify, and distribute this software for
' any purpose and without fee is hereby granted, provided that the
' above copyright notice appears in all copies and that both that
' copyright notice and the limited warranty and restricted rights
' notice below appear in all supporting documentation.
'
' AUTODESK PROVIDES THIS PROGRAM "AS IS" AND WITH ALL FAULTS.
' AUTODESK SPECIFICALLY DISCLAIMS ANY IMPLIED WARRANTY OF
' MERCHANTABILITY OR FITNESS FOR A PARTICULAR USE. AUTODESK, INC.
' DOES NOT WARRANT THAT THE OPERATION OF THE PROGRAM WILL BE
' UNINTERRUPTED OR ERROR FREE.
'
' Use, duplication, or disclosure by the U.S. Government is subject to
' restrictions set forth in FAR 52.227-19 (Commercial Computer
' Software - Restricted Rights) and DFAR 252.227-7013(c)(1)(ii)
' (Rights in Technical Data and Computer Software), as applicable.
'
'
'
Option Explicit



'
' These are all the subroutines that can be called from
' Civil 3D's VBRUN command.
'


'
' Label major contours
'
'
Sub LabelMultipleContours()
'always get the objects again since MDI is supported
If (GetCivilObjects = False) Then
Exit Sub
End If

Dim oSurface As AeccTinSurface

Dim vPoint As Variant

ThisDrawing.Utility.GetEntity oSurface, vPoint, "Select Surface: "

Dim strInput As String

With ThisDrawing.Utility
.InitializeUserInput 0, "Minor mAjor"
strInput = ThisDrawing.Utility.GetKeyword("Enter contour type to label [Minor/mAjor]: ")
End With

Dim dInterval As Double

On Error Resume Next
With ThisDrawing.Utility
.InitializeUserInput 6
dInterval = ThisDrawing.Utility.GetReal("Interval along contour <500>: ")
' If user enters then utilize the default value.
If Err Then
If Err.Number = -2145320928 Then
Err.Clear
dInterval = 500
Else
ThisDrawing.Utility.Prompt Err.Number
Exit Sub
End If
End If
End With

Dim vContours As Variant

Select Case strInput
Case "Minor"
vContours = oSurface.ExtractContour(aeccDisplayOrientationPlan, aeccSFMinorContours, oSurface.Statistics.MinElevation, oSurface.Statistics.MaxElevation)
Case "mAjor"
vContours = oSurface.ExtractContour(aeccDisplayOrientationPlan, aeccSFMajorContours, oSurface.Statistics.MinElevation, oSurface.Statistics.MaxElevation)
End Select


Dim i As Integer
Dim oPoly As AcadLWPolyline
Dim dX1 As Double
Dim dY1 As Double
Dim dX2 As Double
Dim dY2 As Double
Dim dMidX As Double
Dim dMidY As Double
Dim dM As Double
Dim dMPerp As Double
Dim dBasePoint(0 To 2) As Double
Dim dAngle As Double
Dim dAngle2 As Double
Dim vPolarPt As Variant
Dim vPolarPt2 As Variant

For i = 0 To UBound(vContours)
Set oPoly = vContours(i)
dX1 = oPoly.Coordinates(0)
dY1 = oPoly.Coordinates(1)
dX2 = oPoly.Coordinates(2)
dY2 = oPoly.Coordinates(3)

dMidX = (dX1 + dX2) / 2
dMidY = (dY1 + dY2) / 2
dBasePoint(0) = dMidX: dBasePoint(1) = dMidY

dAngle = ThisDrawing.Utility.AngleFromXAxis(oPoly.Coordinate(0), oPoly.Coordinate(1)) + (4 * Atn(1)) / 2 ' Added 90 degrees to the value

vPolarPt = ThisDrawing.Utility.PolarPoint(dBasePoint, dAngle, 0.01)
vPolarPt2 = ThisDrawing.Utility.PolarPoint(dBasePoint, dAngle, -0.1)

ThisDrawing.SendCommand "_AeccAddContourLabelingGroup " & vPolarPt(0) & "," & vPolarPt(1) & " " & vPolarPt2(0) & "," & vPolarPt2(1) & " " & dInterval & " "
oPoly.Delete
Next

End Sub



adf

1 comment:

Tyrone K said...

Thanks Chris. Works as advertised. It's somewhat surprising that this functionality isn't available out of the box.

One small problem I encountered is that the .dvb has a reference to winword 14 (I assume that's for the Office 2010 beta). Remove that reference and it's good to go.

Keep up the good work.

LinkWithin

Blog Widget by LinkWithin