I have a vba routine that creates an mtext with a line's bearing and distance and a curve with its data (we prefer dumb mtext annotation to styles and labels), the routine works fine in C3D 2012 & C3D 2015 as long as we also have Autocad LDD 2009 installed. We're getting to the point where we won't be able to do that, but we also need the annotation routine to work as we move forward.
Here's a portion of the vba code (the entire code is pretty long):
Code:
Function PadNumber(NumIn As Variant, NumOfChars As Integer) As String
PadNumber = NumIn
While Len(PadNumber) < NumOfChars
PadNumber = "0" & PadNumber
Wend
End Function
Function GiveDMS(NumberIn As Double) As String
Dim Ds As String
Dim Ms As String
Dim Ss As String
Dim DegreesRemaining As Double
Degrees = Fix(NumberIn)
Ds = PadNumber(Degrees, 2)
DegreesRemaining = NumberIn - Degrees
Minutes = Fix(DegreesRemaining * 60)
Ms = PadNumber(Minutes, 2)
DegreesRemaining = DegreesRemaining - Minutes / 60
Seconds = Round(DegreesRemaining * 3600, 0)
Ss = PadNumber(Seconds, 2)
Select Case Ss
Case "60"
Ms = PadNumber((Minutes + 1), 2)
Ss = "00"
End Select
Select Case Ms
Case "60"
Ds = PadNumber((Degrees + 1), 2)
Ms = "00"
End Select
GiveDMS = Ds & Chr(176) & Ms & "'" & Ss & """"
End Function
Sub BDinline()
On Error GoTo errhnd
Dim mytext As AcadText
Dim mymtext As AcadMText
Dim MyLine As AcadLine 'selected line to annotate
Dim SelPt As Variant
Dim StPt As Variant
Dim EnPt As Variant
Dim Degrees As Double
Dim Minutes As Double
Dim Seconds As Double
Dim inspt As Variant
Dim Basebearing As Double 'bearing without quadrant
Dim Finalbearing As String 'bearing with quadrant
Dim Length As Double
Dim FinalLength As Double
Dim Pt1 As Variant 'startpoint
Dim Pt2 As Variant 'endpoint
Dim anglefortext As Double
Dim BaseBearingStr As String
Dim GotBearing As Boolean
Dim textboxwidth As Double
Dim Txtsize As Double
Dim CurSc As Double
Dim textstyle As String
Dim Gotfont As Boolean
Dim Txtboxwidth As Variant
CurSc = ThisDrawing.GetVariable("DIMSCALE")
textstyle = ThisDrawing.GetVariable("TEXTSTYLE")
If textstyle = "L80" Then
Txtsize = ThisDrawing.GetVariable("DIMSCALE") * 0.08
Gotfont = True
End If
If textstyle = "L100" And Gotfont = False Then
Txtsize = ThisDrawing.GetVariable("DIMSCALE") * 0.1
End If
If textstyle <> "L100" And textstyle <> "L80" And Gotfont = False Then
MsgBox "Set Style to L80 or L100 and try again."
GoTo errhnd
End If
ThisDrawing.Utility.GetEntity MyLine, SelPt, "Select a line."
MyLine.Highlight True
Pt1 = MyLine.StartPoint
Pt2 = MyLine.EndPoint
If Pt2(0) = Pt1(0) Then
Finalbearing = "NORTH "
GotBearing = True
End If
If Pt2(1) = Pt1(1) And GotBearing = False Then
Finalbearing = "WEST "
GotBearing = True
End If
If GotBearing = False Then
Basebearing = RTD(Atn(Abs(Pt2(0) - Pt1(0)) / Abs(Pt2(1) - Pt1(1))))
BaseBearingStr = GiveDMS(Basebearing)
End If
Length = FormatNumber(Sqr(((Pt2(0) - Pt1(0)) ^ 2 + (Pt2(1) - Pt1(1)) ^ 2)), 5)
FinalLength = RoundIt(Length)
If (Pt2(0) > Pt1(0)) And (Pt2(1) > Pt1(1) And GotBearing = False) _
Or (Pt2(0) < Pt1(0)) And (Pt2(1) < Pt1(1) And GotBearing = False) Then
Finalbearing = "N" & BaseBearingStr & "E "
GotBearing = True
End If
If (Pt2(0) < Pt1(0)) And (Pt2(1) > Pt1(1) And GotBearing = False) _
Or (Pt2(0) > Pt1(0)) And (Pt2(1) < Pt1(1) And GotBearing = False) Then
Finalbearing = "N" & BaseBearingStr & "W "
GotBearing = True
End If
ThisDrawing.ActiveTextStyle.ObliqueAngle = DTR(15)
ThisDrawing.SetVariable "TEXTSIZE", Txtsize
inspt = ThisDrawing.Utility.GetPoint(, "Select insertion point:")
OMode = ThisDrawing.GetVariable("OSMODE")
ThisDrawing.SetVariable "OSMODE", 512
anglefortext = ThisDrawing.Utility.GetAngle(, "Select insertion angle:")
ThisDrawing.SetVariable "OSMODE", 0
MyLine.Highlight False
Txtboxwidth = Len(Finalbearing & FormatNumber(Length, 2) & "'") * (Txtsize)
Set mymtext = ThisDrawing.ModelSpace.AddMText(inspt, (Txtboxwidth), Finalbearing & FormatNumber(FinalLength, 2) & "'")
mymtext.AttachmentPoint = acAttachmentPointBottomCenter
mymtext.InsertionPoint = inspt
mymtext.Rotate inspt, anglefortext
mymtext.Update
Select Case Finalbearing
Case "WEST "
If MsgBox("Keep at WEST?", vbYesNo) = vbNo Then
mymtext.TextString = Replace(mymtext.TextString, "WEST ", "EAST ")
End If
End Select
errhnd:
Select Case Err.number
Case -2147352567
On Error Resume Next
Err.Clear
'ThisDrawing.Regen (acAllViewports)
Case 13
MsgBox "OBJECT IS NOT A LINE!"
Err.Clear
'ThisDrawing.Regen (acAllViewports)
Case Else
'MsgBox "ERROR " & Err.number
Err.Clear
'ThisDrawing.Regen (acAllViewports)
End Select
End Sub
Two questions; 1, is it possible to edit the code so that it works without Autocad LDD 2009? And/or is it easily ported over to .net? I did not write the code, and the guy that did is no longer in our office, so I'm grateful for any help.