As per road Width, Need to classification layer-wise

[MANISH KUMAR SHARMA]

here Closed Road Network Polyline.

 Requirement  :

1.       As per road Width, Need to classification layer-wise with the help of Command Button in single shot within Drawing.

Up to 4 Meter Road Width : Street Road

4  to 10 Meter Road Width : Minor Road

10  to 20 Meter Road Width : Secondary Road

 20 above  Meter Road Width : Major Road

 

 

Private Sub CheckPolylineWidth()

Dim pl1 As AcadPolyline
Dim pl2 As AcadPolyline
Dim pt1 As Variant
Dim pt2 As Variant
Dim Dist As Double

' Set the "OSMODE" variable to Perpedicular
ThisDrawing.SerVariable "osmode,128"


' Select the 2 Polylines.

ThisDrawing.Utility.GetEntity pl1, pt1, "Pick the first Poliline."

pl2 = ThisDrawing.Utility.GetEntity pl1,pt2, "Pick the second Polyline to detect the Road Width."

' Check the distance between the 2 points by drawing a line then get the length of the line

Dim ln As AcadLine
Dim wd As Double
Set ln = ThisDrawing.ModelSpace.AddLine(pt1, pt2)
wd = ln.Length
If (wd <= 4) Then
'Set the layer to StreetRoad
pl1.Layer = "StreetRoad"
pl2.Layer = "StreetRoad"
ElseIf (wd > 4 And wd <= 10) Then

'Set the layer to MinorRoad
pl1.Layer = "MinorRoad"
pl2.Layer = "MinorRoad"
ElseIf (wd > 10 And wd <= 20) Then


' Set the layer to SecondaryRoad
pl1.Layer = "SecondaryRoad"
pl2.Layer = "SecondaryRoad"
ElseIf (wd > 20) Then

' Set the layer to MajorRoad
pl1.Layer = "MajorRoad"
pl2.Layer = "MajorRoad"

Else
      MsgBox "Unable to determine the distance.", vbExclamation + vbOKOnly

End If
'Delete the line reference
ln.Delete
End Sub

 

 

For Query Manish.dwg

Edited August 27, 2018 by CADTutor
Adding code to code block

[SLW210]

Please use Code Tags.

This looks like VBA. Are you wanting it as LISP?

[MANISH KUMAR SHARMA]

8 minutes ago, SLW210 said:

Please use Code Tags.

This looks like VBA. Are you wanting it as LISP?

If can be done by LISP, then provide the LISP.

 

[SLW210]

I asked what you were wanting, you posted in the LISP forum, but the code looks like VBA.

[Grrr]

Quick attempt to fix the VBA code:

Private Sub CheckPolylineWidth()

  Dim pl1 As Object
  Dim pl2 As Object
  Dim pt1 As Variant
  Dim pt2 As Variant
  Dim Dist As Double
 Dim lyrs As AcadLayers

  ' Set the "OSMODE" variable to Perpedicular
  ThisDrawing.SetVariable "osmode", 128


    If Err <> 0 Then
        Err.Clear
        MsgBox "Program ended.", , "First polyline missed"
        Exit Sub
    End If
    
  ' Select the 2 Polylines.

RETRY:
    
    ThisDrawing.Utility.GetEntity pl1, pt1, "Pick the first Poliline."
    
    ThisDrawing.Utility.GetEntity pl2, pt2, "Pick the second Polyline to detect the Road Width"
    
  
    Layers = Array("StreetRoad", "SecondaryRoad", "MinorRoad", "MajorRoad")
   

    For Each Item In Layers
     ThisDrawing.Layers.Add (Item)
   Next
   
  ' Check the distance between the 2 points by drawing a line then get the length of the line

  Dim ln As AcadLine
  Dim wd As Double
  Set ln = ThisDrawing.ModelSpace.AddLine(pt1, pt2)
  wd = ln.Length
  
  If (wd <= 4) Then
    'Set the layer to StreetRoad
    pl1.Layer = "StreetRoad"
    pl2.Layer = "StreetRoad"
    
  ElseIf (wd > 4 And wd <= 10) Then

    'Set the layer to MinorRoad
    pl1.Layer = "MinorRoad"
    pl2.Layer = "MinorRoad"
    
  ElseIf (wd > 10 And wd <= 20) Then

    ' Set the layer to SecondaryRoad
    pl1.Layer = "SecondaryRoad"
    pl2.Layer = "SecondaryRoad"
    
  ElseIf (wd > 20) Then

    ' Set the layer to MajorRoad
    pl1.Layer = "MajorRoad"
    pl2.Layer = "MajorRoad"

  Else
  MsgBox "Unable to determine the distance.", vbExclamation + vbOKOnly

  End If
  'Delete the line reference
  ln.Delete
  
End Sub

Note that it could be improved alot... but I just don't do VBA

[SLW210]

I have moved your thread to the .NET, ObjectARX & VBA Forum