Another popular Export That you can Get from PDMS is and isometric DWG file. But this is a 2D isometric and it is just a sketch. it has dimensions but lengths are not related. if you want a real 3D isometric with correct lengths you should draw again all the lines in a 3d model. It is a tedious work. I myself test it in AutoCAD. so i built an application to Convert 2D isometrics Models to real 3D models.
You Can Download it From Following Link:
Extract RAR archive It Contains 3 Files :
- A .dwg file that contains some PDMS sample files
- a .lsp file
- a .dvb file
Instruction:
- open .dwg file
- Load The lisp and "iso3d.dvb" from Autocad menu-> tools-> Load Application
- in AutoCAD command prompt type iso to start application
- ....
It is really hard to explain some notes on how to use this application. So i built a mp4 Tutorial.
You can Download the Tutorial Here.
Remember These points in mind when using this application:
- Close all other dwg files that are already open and only open one that you want to convert
- Make Osnap OFF
- Begin From START of pipe to the end and follow direction of pipes shown in drawing with Arrow (->). otherwise the direction computed by application will be in opposite direction
- Start of pipe line some times has and (E,N,H)
- in Tee branches type "T' and after finishing branch to continue from beginning of tee branch type "S" to Stop branch
- If you want continue from somewhere in your last drawn isometric, immediately after running "iso.lsp" (by typing iso in command prompt) type "P" for pick point option. this let you select a point 3d isometric and then return to 2d isometric.
This application is not perfect and surely has some bugs. It is because of the nature of PDMS isometric maps. They are not regular and built to be understood by human.
VBA CODE:
For persons who likes to see vba code i decided to bring mu code here. This could be helpful for persons that are familiar with VBA. all of these codes are saved in one Module, named "iso":
Option Explicit
Private docObj1 As AcadDocument
Private docObj2 As AcadDocument
Public Sub iso()
Dim InitPoint As Variant
Dim returnPnt As Variant
Dim FirstVertex(5) As Double
Dim NewVertex As Variant
Dim PolyObj As Acad3DPolyline
Dim AllPolyObj As New Collection
Dim Status() As Variant: Status = Array(1)
Call Newfile
InitPoint = GetInitialPoint()
If IsEmpty(InitPoint) Then
GoTo ErrHandler
Else
FirstVertex(0) = InitPoint(0): FirstVertex(1) = InitPoint(1): FirstVertex(2) = InitPoint(2)
FirstVertex(3) = InitPoint(0): FirstVertex(4) = InitPoint(1): FirstVertex(5) = InitPoint(2)
Set PolyObj = docObj2.ModelSpace.Add3DPoly(FirstVertex): AllPolyObj.Add PolyObj
docObj2.Application.Update
End If
Dim AllCoord As Variant: AllCoord = PolyObj.Coordinates
NewVertex = PolyObj.Coordinate((UBound(AllCoord) + 1) / 3 - 1)
Dim tmp As Variant
docObj1.SendCommand ("syswindows vertical ")
docObj2.SendCommand "-view _swiso "
Dim Azimuth As String
Dim Dist As String
Dim Prompt As String: Dim TS As String: TS = "Select Distance|Direction[Tbranch/Undo]"
Dim Val As String
Dim DirectionCosine() As Double
Dim ReservedAzimuth As String
Dim LastAzimuth
Dim Gdist As Variant
Repeat:
Prompt = ""
On Error GoTo ErrHandler
DirectionCosine = GetDirection(Azimuth, Dist, Status)
Select Case Status(0)
Case 2
AddVertex PolyObj, Azimuth, Dist, DirectionCosine
Case 11
Gdist = GetDistance("Select Distance [" & Azimuth & "] :"): Dist = Gdist(1) 'MsgBox "dist= " & Dist
AddVertex PolyObj, Azimuth, Dist, DirectionCosine
Case 12
Gdist = GetDistance("Select Distance [" & Azimuth & "] :"): Dist = Gdist(1)
AddVertex PolyObj, Azimuth, Dist, DirectionCosine
Case 0
Exit Sub 'MsgBox "Not A Nor D )-:"
Case "T"
AllCoord = PolyObj.Coordinates
NewVertex = PolyObj.Coordinate((UBound(AllCoord) + 1) / 3 - 1)
FirstVertex(0) = NewVertex(0): FirstVertex(1) = NewVertex(1): FirstVertex(2) = NewVertex(2)
FirstVertex(3) = NewVertex(0): FirstVertex(4) = NewVertex(1): FirstVertex(5) = NewVertex(2)
Set PolyObj = docObj2.ModelSpace.Add3DPoly(FirstVertex): AllPolyObj.Add PolyObj
PolyObj.Update
TS = "Selectct Direction [Stopbranch/Undo]": Prompt = "for Stop Branch": Azimuth = "": Dist = ""
Case "S"
Dim PolyCount As Integer: Dim VertCount As Integer: Dim i As Integer
Dim Allvert As Variant
PolyCount = AllPolyObj.Count
NewVertex = AllPolyObj.Item(PolyCount).Coordinate(0)
FirstVertex(0) = NewVertex(0): FirstVertex(1) = NewVertex(1): FirstVertex(2) = NewVertex(2)
FirstVertex(3) = NewVertex(0): FirstVertex(4) = NewVertex(1): FirstVertex(5) = NewVertex(2)
Set PolyObj = docObj2.ModelSpace.Add3DPoly(FirstVertex): AllPolyObj.Add PolyObj
Dist = "": Azimuth = ""
Prompt = "(Resuming Previous Line)": TS = "Select Distance/Direction[Tbranch/Undo]"
Case "U"
Set PolyObj = UndoVertex(AllPolyObj)
PolyObj.Update
Case Else
Exit Sub
End Select
Status = GetDistance(TS & Prompt & "(" & Azimuth & "," & Dist & ")" & ":")
Do While Status(0) > 0
Dist = Status(1)
AddVertex PolyObj, Azimuth, Dist, DirectionCosine
Status = GetDistance(TS & "(" & Azimuth & "," & Dist & ")")
Loop
LastAzimuth = Azimuth
If Status(0) = -3 Then GoTo ErrHandler 'error in get distance
GoTo Repeat
ErrHandler:
Err.Clear
Dim entry As Object
On Error Resume Next
For Each entry In docObj1.ModelSpace
entry.Highlight (False)
Next entry
Exit Sub
End Sub
Private Function UndoVertex(AllPolyObj As Collection) As AcadObject
Dim PolyCount As Integer: Dim VertCount As Integer: Dim i As Integer
Dim Allvert As Variant: Dim UndoVert() As Double
PolyCount = AllPolyObj.Count
Allvert = AllPolyObj.Item(PolyCount).Coordinates
VertCount = UBound(Allvert)
If VertCount = 5 Then
AllPolyObj.Item(PolyCount).Delete
AllPolyObj.Remove (PolyCount)
PolyCount = PolyCount - 1
Allvert = AllPolyObj.Item(PolyCount).Coordinates
VertCount = UBound(Allvert)
End If
ReDim UndoVert(VertCount - 3)
For i = 0 To VertCount - 3
UndoVert(i) = Allvert(i)
Next i
AllPolyObj.Item(PolyCount).Coordinates = UndoVert
docObj2.Regen True
Set UndoVertex = AllPolyObj.Item(PolyCount)
End Function
Private Sub Newfile()
Set docObj1 = ThisDrawing.Application.ActiveDocument
Dim lngDocCount As Long
lngDocCount = Application.Documents.Count
Dim FileName As String: Dim FilePath As String
FileName = "iso3d.dwg": FilePath = "c:\iso3d.dwg"
Dim i As Integer
For i = 0 To lngDocCount - 1
Set docObj2 = Application.Documents(i)
If docObj2.Name = FileName Then
Exit For
End If
Next i
If docObj2.Name <> FileName Then
Set docObj2 = ThisDrawing.Application.Documents.Add
docObj2.SaveAs FilePath
End If
Dim CadLayer As AcadLayer
Dim LayerName As String
FileName = docObj1.Name
lngDocCount = docObj2.Layers.Count
For i = 0 To lngDocCount - 1
Set CadLayer = docObj2.Layers(i)
If CadLayer.Name = FileName Then
docObj2.ActiveLayer = CadLayer
Exit For
End If
Next i
If CadLayer.Name <> FileName Then
Set CadLayer = docObj2.Layers.Add(FileName)
docObj2.ActiveLayer = CadLayer
End If
On Error Resume Next
'For Each CadLayer In docObj2.Layers
' CadLayer.Freeze = True
' Next CadLayer
End Sub
Private Function GetInitialPoint() As Variant
Dim Counter As Integer: Counter = 0
Dim Tmpstr As String
Dim ssetObj As AcadSelectionSet
Dim Coord(0 To 2) As String
Dim Ent As AcadObject
If docObj1.SelectionSets.Count = 0 Then
Set ssetObj = docObj1.SelectionSets.Add("NEWSSET")
End If
GetAgain:
On Error GoTo ErrorHandler
Dim keywordList As String
keywordList = ""
docObj1.Utility.InitializeUserInput 128, keywordList
Dim returnPnt As Variant
returnPnt = docObj1.Utility.GetPoint(, "Enter Initial Point or click on (E,N,H)[Pickpoint]: ")
Set ssetObj = docObj1.SelectionSets.Item(0)
ssetObj.Clear
ssetObj.SelectAtPoint returnPnt
'Control click on space or enter coordinate manually by decimal precision and
'if acidently manualy entered point is on an object
If Int(returnPnt(0) * 1000) = returnPnt(0) * 1000 Then
If ssetObj.Count = 0 Then
GetInitialPoint = returnPnt
Exit Function
End If
ElseIf ssetObj.Count = 0 Then
docObj1.Utility.Prompt "click on text please" & vbCrLf
GoTo GetAgain
ElseIf ssetObj.Count <> 0 Then
On Error Resume Next
For Each Ent In docObj1.ModelSpace
Ent.Highlight (False)
Next Ent
On Error GoTo ErrorHandler
Set Ent = ssetObj.Item(0)
Ent.Highlight (True): docObj1.Application.Update
If Ent.ObjectName <> "AcDbText" Then
Ent.Highlight (False): docObj1.Application.Update
GoTo GetAgain
End If
Tmpstr = Ent.TextString
Select Case Counter
Case 0
If UCase(Left(Tmpstr, 1)) <> "E" Or UCase(Left(Tmpstr, 2)) = "EL" Then
docObj1.Utility.Prompt "Invalid Easting" & vbCrLf
Ent.Highlight (False): docObj1.Application.Update
GoTo GetAgain
End If
Case 1
If UCase(Left(Tmpstr, 1)) <> "N" Then
docObj1.Utility.Prompt "Invalid Northing" & vbCrLf
Ent.Highlight (False): docObj1.Application.Update
GoTo GetAgain
End If
Case 2
If UCase(Left(Tmpstr, 2)) <> "EL" Then
docObj1.Utility.Prompt "Invalid Elavation" & vbCrLf
Ent.Highlight (False): docObj1.Application.Update
GoTo GetAgain
End If
End Select
Coord(Counter) = Ent.TextString
docObj1.Utility.Prompt Coord(Counter) & vbCrLf
Counter = Counter + 1
If Counter = 3 Then
Dim FCoord(0 To 2) As Double
FCoord(0) = CDbl(Right(Coord(0), Len(Coord(0)) - 1))
FCoord(1) = CDbl(Right(Coord(1), Len(Coord(1)) - 1))
FCoord(2) = CDbl(Right(Coord(2), Len(Coord(2)) - 2))
GetInitialPoint = FCoord
Ent.Highlight (False)
Exit Function
End If
GoTo GetAgain
End If
ErrorHandler:
If Err Then
If StrComp(Err.Description, "User input is a keyword", 1) = 0 Then
Dim InputString As String
Err.Clear
InputString = UCase(docObj1.Utility.GetInput)
Select Case InputString
Case "P", "PICK", "PICKPOINT"
docObj2.Activate
If docObj2.SelectionSets.Count = 0 Then Set ssetObj = docObj2.SelectionSets.Add("NEWSSET")
On Error Resume Next
returnPnt = docObj2.Utility.GetPoint(, "Pick a point: ")
If Not IsEmpty(returnPnt) Then GetInitialPoint = returnPnt
Exit Function
Case Else
docObj1.Utility.Prompt "Invalid Coordinate.Try Again" & vbCrLf
Resume GetAgain
End Select
Else
'If IsEmpty(Ent) Then
' Exit Function
'Else
' Ent.Highlight (False)
'End If
End If
End If
End Function
Private Function GetDirection(ByRef Azimuth As String, ByRef Dist As String, ByRef Status() As Variant) As Double()
Dim keywordList As String
Const FP As Integer = 0 'Floating Point Used for Rounding Calculated Azimuth
Dim returnPnt() As Double
Dim ssetObj As AcadSelectionSet
Dim LastObj As AcadObject
Dim objSelectedObj As AcadObject
Dim Tmpstr As String
Set ssetObj = docObj1.SelectionSets.Item(0)
Dim intErr As Long: intErr = -2147352567
Static KeyWord As String
Repeat:
On Error GoTo ErrorHandler
keywordList = ""
docObj1.Utility.InitializeUserInput 128, keywordList
If Not Azimuth = "" Then Tmpstr = "[" & Azimuth & "]):"
Select Case Status(0)
Case -1
'This means user click on a Directing Pline in SelectDistance Function
ReDim returnPnt(2)
returnPnt(0) = CDbl(Status(1)): returnPnt(1) = CDbl(Status(2)): returnPnt(2) = CDbl(Status(3))
Status(0) = 1
Case -2
'This means That user Enter a Keyword in SelectDistance Function
KeyWord = Status(1): Status(0) = 1
Err.Raise -2145320928, , "User input is a keyword"
Case 1
'This id Normal Invoke of Program
'Azimuth = "": Dist = ""
returnPnt = docObj1.Utility.GetPoint(, "Select Distance/Directing Pline or(+-ENH):" & Tmpstr)
End Select
ssetObj.Clear
ssetObj.SelectAtPoint returnPnt
If ssetObj.Count = 0 Then
docObj1.Utility.Prompt "Click ON Coordinate's TEXT|INPUT Coordinate|Pick a point" & vbCrLf
GoTo Repeat
End If
If ssetObj.Count <> 0 Then
Set objSelectedObj = ssetObj.Item(0)
Dim entry As Object
On Error Resume Next
For Each entry In docObj1.ModelSpace
entry.Highlight (False)
Next entry
On Error GoTo ErrorHandler
objSelectedObj.Highlight True: docObj1.Application.Update
If objSelectedObj.ObjectName <> "AcDbPolyline" Then
If Not Azimuth = "" Then
If objSelectedObj.ObjectName = "AcDbText" Then
Dist = objSelectedObj.TextString
If IsNumeric(Dist) Then
Status(0) = 2
Exit Function
End If
End If
End If
docObj1.Utility.Prompt "Invalid Directing PLINE" & vbCrLf
GoTo Repeat
Else
'//////////////////////////////////////////////////////////////////////////////////////
'These Check Thikness of Pline ignore it to ignore thiknes validity of Directing Plines
'If objSelectedObj.ConstantWidth <> 1 Then
' docObj1.Utility.Prompt "Invalid Pline" & vbCrLf
' GoTo Repeat
'End If
'//////////////////////////////////////////////////////////////////////////////////////
Dim Scoord(2) As Double
Dim ECoord(2) As Double
Scoord(0) = objSelectedObj.Coordinate(0)(0): Scoord(1) = objSelectedObj.Coordinate(0)(1): Scoord(2) = 0
ECoord(0) = objSelectedObj.Coordinate(1)(0): ECoord(1) = objSelectedObj.Coordinate(1)(1): ECoord(2) = 0
Azimuth = Round(Abs(360 - docObj1.Utility.AngleFromXAxis(Scoord, ECoord) * 180 / 3.1415) + 90, FP)
If Azimuth >= 360 Then Azimuth = Azimuth - 360
Select Case Azimuth
Case 60
Azimuth = "+E"
Case 300
Azimuth = "+N"
Case 0
Azimuth = "+H"
Case 240
Azimuth = "-E"
Case 120
Azimuth = "-N"
Case 180
Azimuth = "-H"
Case Else
KeyWord = UCase(docObj1.Utility.GetString(False, "Enter 2D Direction{+-}(E|N|H)):"))
Err.Raise -2145320928, , "User input is a keyword"
End Select
GoTo Repeat
End If
End If
ErrorHandler:
If StrComp(Err.Description, "User input is a keyword", 1) = 0 Then
KeyWord = UCase(docObj1.Utility.GetInput)
If IsNumeric(KeyWord) Then
If Not Tmpstr = "" Then 'check user donot enter number at the first prompt
Dist = KeyWord
Status(0) = 2
Exit Function
End If
docObj1.Utility.Prompt "First DIRECTION Then Distance" & vbCrLf
Azimuth = ""
Resume Repeat
Else
Dim Gdist() As Variant
Dim Dist1 As Double: Dim Dist2 As Double: Dim Ds As Double
Dim tmp(2) As Double
Select Case KeyWord
Case "E", "+E", "X", "+X"
Azimuth = "+E": Status(0) = 11: Exit Function
Case "-E", "-X"
Azimuth = "-E": Status(0) = 11: Exit Function
Case "N", "+N", "+Y", "Y"
Azimuth = "+N": Status(0) = 11: Exit Function
Case "-N", "-Y"
Azimuth = "-N": Status(0) = 11: Exit Function
Case "H", "+H", "+Z", "Z"
Azimuth = "+H": Status(0) = 11: Exit Function
Case "-H", "-Z"
Azimuth = "-H": Status(0) = 11: Exit Function
Case "+E+N", "E+N", "+EN", "EN", "+X+Y", "X+Y", "+XY", "XY"
Azimuth = "+E+N"
Gdist = GetDistance("Enter Distance in " & "(+E) " & "Direction:"): Dist1 = Gdist(1)
Gdist = GetDistance("Enter Distance in " & "(+N) " & "Direction:"): Dist2 = Gdist(1)
Ds = Sqr(Dist1 ^ 2 + Dist2 ^ 2)
tmp(0) = Dist1 / Ds: tmp(1) = Dist2 / Ds: tmp(2) = 0
GetDirection = tmp: Status(0) = 12: Exit Function
Case "+E-N", "E-N", "+X-Y", "X-Y"
Azimuth = "+E-N"
Gdist = GetDistance("Enter Distance in " & "(+E) " & "Direction:"): Dist1 = Gdist(1)
Gdist = GetDistance("Enter Distance in " & "(-N) " & "Direction:"): Dist2 = Gdist(1)
Ds = Sqr(Dist1 ^ 2 + Dist2 ^ 2)
tmp(0) = Dist1 / Ds: tmp(1) = -Dist2 / Ds: tmp(2) = 0
GetDirection = tmp: Status(0) = 12: Exit Function
Case "-E+N", "-EN", "-X+Y", "-XY"
Azimuth = "-E+N"
Gdist = GetDistance("Enter Distance in " & "(-E) " & "Direction:"): Dist1 = Gdist(1)
Gdist = GetDistance("Enter Distance in " & "(+N) " & "Direction:"): Dist2 = Gdist(1)
Ds = Sqr(Dist1 ^ 2 + Dist2 ^ 2)
tmp(0) = -Dist1 / Ds: tmp(1) = Dist2 / Ds: tmp(2) = 0
GetDirection = tmp: Status(0) = 12: Exit Function
Case "-E-N", "-X-Y"
Azimuth = "-E-N"
Gdist = GetDistance("Enter Distance in " & "(-E) " & "Direction:"): Dist1 = Gdist(1)
Gdist = GetDistance("Enter Distance in " & "(-N) " & "Direction:"): Dist2 = Gdist(1)
Ds = Sqr(Dist1 ^ 2 + Dist2 ^ 2)
tmp(0) = -Dist1 / Ds: tmp(1) = -Dist2 / Ds: tmp(2) = 0
GetDirection = tmp: Status(0) = 12: Exit Function
Case "+E+H", "EH", "+EH", "E+H", "+X+Z", "XZ", "+XZ", "X+Z"
Azimuth = "+E+H"
Gdist = GetDistance("Enter Distance in " & "(+E) " & "Direction:"): Dist1 = Gdist(1)
Gdist = GetDistance("Enter Distance in " & "(+H) " & "Direction:"): Dist2 = Gdist(1)
Ds = Sqr(Dist1 ^ 2 + Dist2 ^ 2)
tmp(0) = Dist1 / Ds: tmp(1) = 0: tmp(2) = Dist2 / Ds
GetDirection = tmp: Status(0) = 12: Exit Function
Case "+E-H", "E-H", "+X-Z", "X-Z"
Azimuth = "+E-H"
Gdist = GetDistance("Enter Distance in " & "(+E) " & "Direction:"): Dist1 = Gdist(1)
Gdist = GetDistance("Enter Distance in " & "(-H) " & "Direction:"): Dist2 = Gdist(1)
Ds = Sqr(Dist1 ^ 2 + Dist2 ^ 2)
tmp(0) = Dist1 / Ds: tmp(1) = 0: tmp(2) = -Dist2 / Ds
GetDirection = tmp: Status(0) = 12: Exit Function
Case "-E+H", "-EH", "-X+Z", "-XZ"
Azimuth = "-E+H"
Gdist = GetDistance("Enter Distance in " & "(-E) " & "Direction:"): Dist1 = Gdist(1)
Gdist = GetDistance("Enter Distance in " & "(+H) " & "Direction:"): Dist2 = Gdist(1)
Ds = Sqr(Dist1 ^ 2 + Dist2 ^ 2)
tmp(0) = -Dist1 / Ds: tmp(1) = 0: tmp(2) = Dist2 / Ds
GetDirection = tmp: Status(0) = 12: Exit Function
Case "-E-H", "-X-Z"
Azimuth = "-E-H"
Gdist = GetDistance("Enter Distance in " & "(-E) " & "Direction:"): Dist1 = Gdist(1)
Gdist = GetDistance("Enter Distance in " & "(-H) " & "Direction:"): Dist2 = Gdist(1)
Ds = Sqr(Dist1 ^ 2 + Dist2 ^ 2)
tmp(0) = -Dist1 / Ds: tmp(1) = 0: tmp(2) = -Dist2 / Ds
GetDirection = tmp: Status(0) = 12: Exit Function
Case "+N+H", "+NH", "N+H", "NH", "+Y+Z", "+YZ", "Y+Z", "YZ"
Azimuth = "+N+H"
Gdist = GetDistance("Enter Distance in " & "(+N) " & "Direction:"): Dist1 = Gdist(1)
Gdist = GetDistance("Enter Distance in " & "(+H) " & "Direction:"): Dist2 = Gdist(1)
Ds = Sqr(Dist1 ^ 2 + Dist2 ^ 2)
tmp(0) = 0: tmp(1) = Dist1 / Ds: tmp(2) = Dist2 / Ds
GetDirection = tmp: Status(0) = 12: Exit Function
Case "+N-H", "N-H", "+Y-Z", "Y-Z"
Azimuth = "+N-H"
Gdist = GetDistance("Enter Distance in " & "(+N) " & "Direction:"): Dist1 = Gdist(1)
Gdist = GetDistance("Enter Distance in " & "(-H) " & "Direction:"): Dist2 = Gdist(1)
Ds = Sqr(Dist1 ^ 2 + Dist2 ^ 2)
tmp(0) = 0: tmp(1) = Dist1 / Ds: tmp(2) = -Dist2 / Ds
GetDirection = tmp: Status(0) = 12: Exit Function
Case "-N+H", "-NH", "-Y+Z", "-YZ"
Azimuth = "-N+H"
Gdist = GetDistance("Enter Distance in " & "(-N) " & "Direction:"): Dist1 = Gdist(1)
Gdist = GetDistance("Enter Distance in " & "(+H) " & "Direction:"): Dist2 = Gdist(1)
Ds = Sqr(Dist1 ^ 2 + Dist2 ^ 2)
tmp(0) = 0: tmp(1) = -Dist1 / Ds: tmp(2) = Dist2 / Ds
GetDirection = tmp: Status(0) = 12: Exit Function
Case "-N-H", "-Y-Z"
Azimuth = "-N-H"
Gdist = GetDistance("Enter Distance in " & "(-N) " & "Direction:"): Dist1 = Gdist(1)
Gdist = GetDistance("Enter Distance in " & "(-H) " & "Direction:"): Dist2 = Gdist(1)
Ds = Sqr(Dist1 ^ 2 + Dist2 ^ 2)
tmp(0) = 0: tmp(1) = -Dist1 / Ds: tmp(2) = -Dist2 / Ds
GetDirection = tmp: Status(0) = 12: Exit Function
Case "T"
Status(0) = "T": Exit Function
Case "S"
Status(0) = "S": Exit Function
Case "U", "UNDO"
Status(0) = "U": Exit Function
Case Else
docObj1.Utility.Prompt "Invalid KEYWORD" & vbCrLf
Resume Repeat
End Select
End If
ElseIf Err.Number = intErr Then
Err.Clear
intErr = 0
Resume Repeat
Else
Status(0) = 0
objSelectedObj.Highlight (False)
'Err.Clear
End If
End Function
Private Function GetDistance(Prompt As String) As Variant()
Dim keywordList As String
Dim returnPnt As Variant
Dim ssetObj As AcadSelectionSet
Dim KeyWord As String
Set ssetObj = docObj1.SelectionSets.Item(0)
If Prompt = "" Then Prompt = "Enter Distance[Tbranch/Undo]:"
Repeat:
On Error GoTo ErrorHandler
keywordList = ""
docObj1.Utility.InitializeUserInput 128, keywordList
returnPnt = docObj1.Utility.GetPoint(, Prompt)
ssetObj.Clear
ssetObj.SelectAtPoint returnPnt
If ssetObj.Count = 0 Then
docObj1.Utility.Prompt "Click On Distance's TEXT" & vbCrLf
GoTo Repeat
End If
If ssetObj.Count <> 0 Then
Dim entry As Object
On Error Resume Next
For Each entry In docObj1.ModelSpace
entry.Highlight (False)
Next entry
On Error GoTo ErrorHandler
ssetObj.Item(0).Highlight True: docObj1.Application.Update
If ssetObj.Item(0).ObjectName <> "AcDbText" Then
If ssetObj.Item(0).ObjectName = "AcDbPolyline" Then
Dim Ent As AcadLWPolyline
Set Ent = ssetObj.Item(0)
If Ent.ConstantWidth = 1 Then
GetDistance = Array(-1, returnPnt(0), returnPnt(1), returnPnt(2))
Exit Function
Else
docObj1.Utility.Prompt "Click|Input On Directin PLINE|Distance Text" & vbCrLf
GoTo Repeat
End If
Else
docObj1.Utility.Prompt "Click|Input On Directin PLINE|Distance Text" & vbCrLf
GoTo Repeat
End If
Else
Dim Entxt As AcadText
Set Entxt = ssetObj.Item(0)
Dim Dist As String
Dist = Entxt.TextString
If IsNumeric(Dist) Then
GetDistance = Array(1, CDbl(Dist))
Exit Function
Else
docObj1.Utility.Prompt "Not a Valid Object For DISTANCE|DIRECTION" & vbCrLf
GoTo Repeat
End If
End If
End If
ErrorHandler:
If Err Then
If StrComp(Err.Description, "User input is a keyword", 1) = 0 Then
Err.Clear
KeyWord = UCase(docObj1.Utility.GetInput)
If IsNumeric(KeyWord) Then
GetDistance = Array(1, CDbl(KeyWord)) 'user input a distance(Number) keyword
Exit Function
Else
GetDistance = Array(-2, KeyWord) 'user input a keyword
Exit Function
End If
Else
Err.Clear
GetDistance = Array(-3, -3)
Exit Function
End If
End If
End Function
Private Function AddVertex(PolyObj As Acad3DPolyline, Azimuth As String, Dist As String, DirectionCosine() As Double)
On Error GoTo ErrHandler
Dim AllCoord As Variant: AllCoord = PolyObj.Coordinates
Dim LastVertex As Variant
LastVertex = PolyObj.Coordinate((UBound(AllCoord) + 1) / 3 - 1)
If Not IsNumeric(Dist) Then
docObj1.Utility.Prompt "Invalid Distance!" & vbCrLf
GoTo ErrHandler
End If
docObj2.StartUndoMark
Select Case Azimuth
Case "+E"
LastVertex(0) = LastVertex(0) + Dist
PolyObj.AppendVertex (LastVertex)
Case "+N"
LastVertex(1) = LastVertex(1) + Dist
PolyObj.AppendVertex (LastVertex)
Case "+H"
LastVertex(2) = LastVertex(2) + Dist
PolyObj.AppendVertex (LastVertex)
Case "-E"
LastVertex(0) = LastVertex(0) - Dist
PolyObj.AppendVertex (LastVertex)
Case "-N"
LastVertex(1) = LastVertex(1) - Dist
PolyObj.AppendVertex (LastVertex)
Case "-H"
LastVertex(2) = LastVertex(2) - Dist
PolyObj.AppendVertex (LastVertex)
Case Else
LastVertex(0) = LastVertex(0) + DirectionCosine(0) * Dist
LastVertex(1) = LastVertex(1) + DirectionCosine(1) * Dist
LastVertex(2) = LastVertex(2) + DirectionCosine(2) * Dist
PolyObj.AppendVertex (LastVertex)
End Select
' Dim LLeft As Variant: Dim URight As Variant
'PolyObj.GetBoundingBox LLeft, URight
docObj2.Activate
'ZoomWindow LLeft, URight
ZoomExtents
ZoomAll
ZoomScaled 0.8, acZoomScaledRelative
PolyObj.Update
docObj2.EndUndoMark
ErrHandler:
If Err Then
Err.Clear
Exit Function
End If
End Function