Nearest Point Using VBA

[fixo]

Sorry fixo....

 

Now i had made in the same way u wanted with before executing program and after executing program ..

 

Hope it is enough..ifnot tell me...i will prepare in which ever way u want...

 

tanx for help

Try edited project

 

~'J'~

UsingVlax.zip

[bhargav1987]

This may be a viable alternative to searching for the closest line. Run the routine with the attached file and window select the text entities.

 

Private Sub InsertArrow()
Dim fType(1) As Integer
Dim fData(1) As Variant
Dim entText As AcadText
Dim ent As AcadEntity
Dim dblValue As Double
Dim dblRotation As Double
Dim entInsert As AcadBlockReference

  fType(0) = 0: fData(0) = "TEXT"
  fType(1) = 62: fData(1) = 202
  If SoSSS(fType, fData) > 0 Then
     For Each entText In ThisDrawing.SelectionSets.Item("TempSSet")
        dblValue = ThisDrawing.Utility.DistanceToReal(entText.TextString, acDecimal)
        dblRotation = entText.Rotation
        If dblValue > 0 Then
            Set entInsert = ThisDrawing.ModelSpace.InsertBlock(entText.InsertionPoint, "ArrowPos", 1, 1, 1, dblRotation)
        Else
           Set entInsert = ThisDrawing.ModelSpace.InsertBlock(entText.InsertionPoint, "ArrowNeg", 1, 1, 1, dblRotation)
        End If
     Next
  End If
End Sub

Sub SSClear()
Dim SSS As AcadSelectionSets
  On Error Resume Next
  Set SSS = ThisDrawing.SelectionSets
     If SSS.Count > 0 Then
        SSS.Item("TempSSet").Delete
        SSS.Item("RemoveSSet").Delete
        SSS.Item("EntireSS").Delete
     End If
End Sub

Function SoSSS(Optional grpCode As Variant, Optional dataVal As Variant) As Integer
  Dim TempObjSS As AcadSelectionSet
  SSClear
  Set TempObjSS = ThisDrawing.SelectionSets.Add("TempSSet")
        'pick selection set
  If IsMissing(grpCode) Then
     TempObjSS.SelectOnScreen
  Else
     TempObjSS.SelectOnScreen grpCode, dataVal
  End If
  SoSSS = TempObjSS.Count
End Function

Thank ypu very much for this quick reply..

i will check out nd revert back to u

 

If possible can u tell me in brief wat this particular script will do...

[bhargav1987]

Try edited project

 

~'J'~

Thank ypu very much for this quick reply..

i will check out nd revert back to u

 

If possible can u tell me in brief wat this particular script will do...

[fixo]

Thank ypu very much for this quick reply..

i will check out nd revert back to u

 

If possible can u tell me in brief wat this particular script will do...

Sorry, english is not my native language so

I can't explain you all the lines of code right

 

~'J'~

[bhargav1987]

Sorry, english is not my native language so

I can't explain you all the lines of code right

 

~'J'~

Ok..

tanx for the code..fixo..Dont get embrassed..I just asked..tat's it

 

i just have one more doubt..is there any possibility to find all the coordinates through which a polyline is passing(Not only Starting and ending point)

[bhargav1987]

This may be a viable alternative to searching for the closest line. Run the routine with the attached file and window select the text entities.

 

Private Sub InsertArrow()
Dim fType(1) As Integer
Dim fData(1) As Variant
Dim entText As AcadText
Dim ent As AcadEntity
Dim dblValue As Double
Dim dblRotation As Double
Dim entInsert As AcadBlockReference

  fType(0) = 0: fData(0) = "TEXT"
  fType(1) = 62: fData(1) = 202
  If SoSSS(fType, fData) > 0 Then
     For Each entText In ThisDrawing.SelectionSets.Item("TempSSet")
        dblValue = ThisDrawing.Utility.DistanceToReal(entText.TextString, acDecimal)
        dblRotation = entText.Rotation
        If dblValue > 0 Then
            Set entInsert = ThisDrawing.ModelSpace.InsertBlock(entText.InsertionPoint, "ArrowPos", 1, 1, 1, dblRotation)
        Else
           Set entInsert = ThisDrawing.ModelSpace.InsertBlock(entText.InsertionPoint, "ArrowNeg", 1, 1, 1, dblRotation)
        End If
     Next
  End If
End Sub

Sub SSClear()
Dim SSS As AcadSelectionSets
  On Error Resume Next
  Set SSS = ThisDrawing.SelectionSets
     If SSS.Count > 0 Then
        SSS.Item("TempSSet").Delete
        SSS.Item("RemoveSSet").Delete
        SSS.Item("EntireSS").Delete
     End If
End Sub

Function SoSSS(Optional grpCode As Variant, Optional dataVal As Variant) As Integer
  Dim TempObjSS As AcadSelectionSet
  SSClear
  Set TempObjSS = ThisDrawing.SelectionSets.Add("TempSSet")
        'pick selection set
  If IsMissing(grpCode) Then
     TempObjSS.SelectOnScreen
  Else
     TempObjSS.SelectOnScreen grpCode, dataVal
  End If
  SoSSS = TempObjSS.Count
End Function

i just have one more doubt Mr.seant..is there any possibility to find all the coordinates through which a polyline is passing(Not only Starting and ending point)

[fixo]

Ok..

tanx for the code..fixo..Dont get embrassed..I just asked..tat's it

 

i just have one more doubt..is there any possibility to find all the coordinates through which a polyline is passing(Not only Starting and ending point)

 

See Help

Coordinates property

 

~'J'~

[bhargav1987]

See Help

Coordinates property

 

~'J'~

 

I am attaching an image...

 

in tat if red line is present..

i want to draw automatically cyan line by click of red line..is it possible

[fixo]

Better yet to start learning Lisp

Anyway give this a shot

 

Option Explicit
Sub DrawOverPline()
Dim oEnt As AcadEntity
Dim varPt As Variant
Dim oLine As AcadLine
Dim oPline As AcadLWPolyline
Dim copyPline As AcadLWPolyline
Dim cpt As Variant
With ThisDrawing
.Utility.GetEntity oEnt, varPt, vbCr & "   >>   Select pline >>"
If Not TypeOf oEnt Is AcadLWPolyline Then Exit Sub
Set oPline = oEnt
.SetVariable "OSMODE", 2
cpt = .Utility.GetPoint(, vbCr & "   >>  Pick center point of polyline (using snap) >> ")
Set copyPline = oPline.Copy
copyPline.ScaleEntity cpt, 0.5
copyPline.Lineweight = acLnWt050
copyPline.color = acCyan
End With
End Sub

 

Keep in mind this woul works just with polyline

that has 2 coordinates only as on your drawing

 

~'J'~