Dimension Help

[Anonymous]

I have created a dimension routine that will create a string of dimensions with the ability to place centerlines at indicated locations. This routine is meant to place strings at certain intervals away from the selected start point based on baseline spacing. My problem is, I would like to be able to pick the string location similar to the way the regular dimension command works. I currently use snap which works ok, but I want to make this routine work just like base autocad. Here is what I have so far. Feel free to critique. You will have to replace MJ-Center8 with Center linetype or it will error.

Sub StringDims()
Dim objSpaceBlk As AcadBlock
Dim DimLayer As AcadLayer, lineObj As AcadLine, dimObj As AcadDimRotated
Dim P1 As Variant, P2 As Variant, P3 As Variant, PA As Variant, PL As Variant, PP As Variant, PX As Variant
Dim objLine1 As AcadLine, objLine2 As AcadLine, tempAngle As Double
Dim xDif As Double, yDif As Double, rotAngleRad As Double, rotAngle As Double, SnapDist As Double
Dim OldOSnap As Integer, OldAutoSnap As Integer, OldOrtho As Integer, OldSnap As Integer, OldSnapAngle As Double
Dim tempar(0 To 1) As Double, KeywordList As String, inputString As String
Dim dimscale As Double, dimdec As Integer, dimlunit As Integer, dimexo As Double
Dim arUndo(0 To 100, 0 To 2) As Variant, i As Integer, objUndo As Object
Dim isAligned As Boolean, dimMode As String

isAligned = True

If ThisDrawing.ActiveSpace = acPaperSpace Then
If ThisDrawing.MSpace = False Then
Set objSpaceBlk = ThisDrawing.ActiveLayout.block
Else
Set objSpaceBlk = ThisDrawing.Layouts("Model").block
End If
Else
Set objSpaceBlk = ThisDrawing.Layouts("Model").block
End If

If UCase(ThisDrawing.Path) Like "*BAUHAUS*" Or UCase(ThisDrawing.Path) Like "*THROCK*" Or UCase(ThisDrawing.Path) Like "*DESKTOP*" Then
Set DimLayer = ThisDrawing.Layers.Add("Dimensions")
DimLayer.color = acRed
ThisDrawing.ActiveLayer = DimLayer
Else
AEC_GenerateScaleLayer ("DIMLINE")
End If

On Error Resume Next
If ThisDrawing.GetVariable("measurement") = 0 Then
ThisDrawing.Linetypes.Load "MJ-Center8", "MJ-acad.lin"
Else
ThisDrawing.Linetypes.Load "MJ-Center8", "MJ-acadiso.lin"
End If
Err.Clear

OldOSnap = ThisDrawing.GetVariable("osmode")
OldAutoSnap = ThisDrawing.GetVariable("autosnap")
OldSnap = ThisDrawing.GetVariable("snapmode")
OldOrtho = ThisDrawing.GetVariable("orthomode")
OldSnapAngle = ThisDrawing.GetVariable("snapang")
dimscale = ThisDrawing.GetVariable("dimscale")
dimdec = ThisDrawing.GetVariable("dimdec")
dimlunit = ThisDrawing.GetVariable("dimlunit")
dimexo = ThisDrawing.GetVariable("dimexo") * dimscale
dimMode = "Normal"

SnapDist = ThisDrawing.GetVariable("dimdli") * dimscale
P1 = ThisDrawing.Utility.GetPoint(, "Pick first point in string ")
If Err Then
GoTo ExitSub
End If
On Error GoTo ErrorCheck

'Set Undo value
arUndo(0, 0) = P1
i = 1
PP = P1
LoopString:
Do
' Call InitializeUserInput to set up the keywords
KeywordList = "Normal End Center Undo"
ThisDrawing.Utility.InitializeUserInput 128, KeywordList
If IsEmpty(P2) Then
Select Case dimMode
Case Is = "Normal"
P2 = ThisDrawing.Utility.GetPoint(PP, vbCrLf & "Pick next point in string or [End/Center/Undo] : ")
Case Is = "Center"
P2 = ThisDrawing.Utility.GetPoint(, vbCrLf & "Pick center point or [Normal/End/Undo] : ")
Case Is = "End"
P2 = ThisDrawing.Utility.GetPoint(PP, vbCrLf & "Pick last point in string [Normal/Center/Undo]: ")
End Select
End If
If IsEmpty(PL) Then
ThisDrawing.SetVariable "orthomode", 1
tempar(0) = SnapDist: tempar(1) = SnapDist
ThisDrawing.SetVariable "snapunit", tempar
tempar(0) = P1(0): tempar(1) = P1(1)
ThisDrawing.SetVariable "snapbase", tempar
ThisDrawing.SetVariable "snapmode", 1
ThisDrawing.SetVariable "osmode", 16384 + OldSnap
If isAligned Then
tempAngle = ThisDrawing.Utility.AngleFromXAxis(P1, P2) - DegToRad(90)
ThisDrawing.SetVariable "snapang", tempAngle
KeywordList = "Linear"
ThisDrawing.Utility.InitializeUserInput 128, KeywordList
PL = ThisDrawing.Utility.GetPoint(P1, "Pick dimension line location or [Linear] : ")
Else
ThisDrawing.SetVariable "snapang", OldSnapAngle
KeywordList = "Aligned"
ThisDrawing.Utility.InitializeUserInput 128, KeywordList
PL = ThisDrawing.Utility.GetPoint(P1, "Pick dimension line location or [Aligned] : ")
End If
ThisDrawing.SetVariable "snapmode", OldSnap
ThisDrawing.SetVariable "osmode", OldOSnap
ThisDrawing.SetVariable "orthomode", OldOrtho
ThisDrawing.SetVariable "autosnap", OldAutoSnap
rotAngle = ThisDrawing.Utility.AngleFromXAxis(P1, PL) - DegToRad(90)
End If
Set objLine1 = objSpaceBlk.AddLine(PL, ThisDrawing.Utility.PolarPoint(PL, rotAngle, 1))
Set objLine2 = objSpaceBlk.AddLine(P2, ThisDrawing.Utility.PolarPoint(P2, rotAngle + DegToRad(90), 1))
PX = objLine1.IntersectWith(objLine2, acExtendBoth)
objLine1.Delete: Set objLine1 = Nothing
objLine2.Delete: Set objLine2 = Nothing
Select Case dimMode
Case Is = "Normal"
P2 = ThisDrawing.Utility.PolarPoint(PX, rotAngle - DegToRad(90), SnapDist)
Set dimObj = objSpaceBlk.AddDimRotated(PP, P2, PL, rotAngle)
dimObj.ScaleFactor = dimscale
ThisDrawing.Utility.Prompt "Dimension text : " & ThisDrawing.Utility.RealToString(dimObj.Measurement, dimlunit, dimdec)
Case Is = "Center"
P2 = PX
P3 = ThisDrawing.Utility.PolarPoint(P2, rotAngle - DegToRad(90), SnapDist - dimexo)
Set dimObj = objSpaceBlk.AddDimRotated(PP, P2, PL, rotAngle)
dimObj.ScaleFactor = dimscale
ThisDrawing.Utility.Prompt "Dimension text : " & ThisDrawing.Utility.RealToString(dimObj.Measurement, dimlunit, dimdec)
Set lineObj = objSpaceBlk.AddLine(P2, P3)
lineObj.Linetype = "MJ-Center8"
Case Is = "End"
Set dimObj = objSpaceBlk.AddDimRotated(PP, P2, PL, rotAngle)
dimObj.ScaleFactor = dimscale
ThisDrawing.Utility.Prompt "Dimension text : " & ThisDrawing.Utility.RealToString(dimObj.Measurement, dimlunit, dimdec)
GoTo ExitSub
End Select
'Set Undo value
arUndo(i, 0) = P2: arUndo(i, 1) = dimObj.objectID
i = i + 1
PP = P2
P2 = Empty
Loop

UndoString:
i = i - 1
If Not IsEmpty(arUndo(i, 1)) Then
Set objUndo = ThisDrawing.ObjectIdToObject(arUndo(i, 1))
objUndo.Delete
End If
If Not IsEmpty(arUndo(i, 2)) Then
Set objUndo = ThisDrawing.ObjectIdToObject(arUndo(i, 2))
objUndo.Delete
End If
PP = arUndo(i - 1, 0)
arUndo(i, 0) = Empty
arUndo(i, 1) = Empty
arUndo(i, 2) = Empty
GoTo LoopString

ErrorCheck:

If Err Then
If StrComp(Err.Description, "User input is a keyword", 1) = 0 Then
' One of the keywords was entered
Err.Clear
inputString = ThisDrawing.Utility.GetInput
If inputString = vbNullString Then
If Not IsEmpty(PL) Xor (IsEmpty(PL) And IsEmpty(P2)) Then
inputString = "End"
Else
If isAligned Then
inputString = "Linear"
Else
inputString = "Aligned"
End If
End If
End If
Select Case inputString
Case Is = "Aligned": isAligned = True: Resume LoopString
Case Is = "Linear": isAligned = False: Resume LoopString
Case Is = "Normal": dimMode = inputString: Resume LoopString
Case Is = "End": dimMode = inputString: Resume LoopString
Case Is = "Center": dimMode = inputString: Resume LoopString
Case Is = "Undo": Resume UndoString
End Select
Else
Err.Clear
Resume ExitSub
End If
End If

ExitSub:
ThisDrawing.SetVariable "snapmode", OldSnap
ThisDrawing.SetVariable "osmode", OldOSnap
ThisDrawing.SetVariable "orthomode", OldOrtho
ThisDrawing.SetVariable "autosnap", OldAutoSnap
ThisDrawing.SetVariable "snapang", OldSnapAngle
If Not objLine1 Is Nothing Then objLine1.Delete
If Not objLine2 Is Nothing Then objLine2.Delete

End Sub

Public Function CurrentSpace() As AcadBlock
If ThisDrawing.ActiveSpace = acPaperSpace Then
If ThisDrawing.MSpace = False Then
Set CurrentSpace = ThisDrawing.ActiveLayout.block
Else
Set CurrentSpace = ThisDrawing.Blocks("*MODEL_SPACE")
End If
Else
Set CurrentSpace = ThisDrawing.Blocks("*MODEL_SPACE")
End If

End Function