Xin trợ giúp về polyline trong VBA

[kegiaumat 2]

e có một đường pline nhiều đỉnh. em muốn code VBA thực hiện như sau: 

gọi lệnh -> con trỏ cho phép chọn pline -> mình chỉ vào pline (chỉ vào 1 2 3.. điểm trên pline) -> code sẽ thông báo các đoạn mà mình vừa pick lên pline đó (nếu trong quá trình mình chọn pline  mà đoạn pline đó sáng lên được thì tuyệt. Cảm ơn mọi người đã quan tâm

[kegiaumat 2]

Hic hic ko ai giúp à thế em hỏi các bác trong VBA có hàm nào giống như trong lisp ko

vlax-curve-getParamAtPoint => ?

vlax-curve-getClosestPointTo => ?

[vstran 10]

mình cũng đang bị vướng giống bạn

vẫn chưa tìm ra hướng giải quyết.

tuy nhiên có 1 cách đó là sử dụng hàm này của lisp đê sử dụng trong vba bằng cách sử dụng 2 class curve.cls và vlax.cls

Nếu anh em nào có hướng giải quyết vấn đề này bằng vba thì giúp với.

hàm tìm 1 điểm gần nhất từ 1 điểm đến 1 polyline (polyline có cả line và arc )

[NguyenNgocSon 43]

Tham khảo code này nhé, Code box diễn đàn lỗi thì phải ?

Sub Distan_PointToPL()
ThisDrawing.SetVariable "OSMODE", 515
Dim C(1) As Double
Dim X() As Double
Dim Y() As Double
Dim m, n, j, i, k, VT As Integer
Dim returnPnt As Variant
Dim Ktra As Boolean
Dim ktONLINE As Boolean
ktONLINE = False
Dim varPt As Variant
Dim oEnt As AcadEntity
Dim Tim As AcadLWPolyline
ThisDrawing.Utility.GetEntity oEnt, varPt, vbCr & "Select polyline"
If TypeOf oEnt Is AcadLWPolyline Then
    Set Tim = oEnt
End If
n = GetVertexCount(Tim) - 1
ReDim X(n)
ReDim Y(n)
For m = 0 To n
X(m) = Tim.Coordinates(2 * m) 'Toa do X cua PL
Y(m) = Tim.Coordinates(2 * m + 1) 'Toa do Y cua PL
Next m
Ktra = True
i = 0
k = 0
Dim KC As Double
'------------------------------------------------------------------------------------------------
While Ktra = True
On Error GoTo thoat
    i = i + 1
    returnPnt = ThisDrawing.Utility.GetPoint(, vbCrLf & UNC("Pick diem thuoc Polyline ") & i & ":")
For m = 0 To n - 1
KC = 0
ktONLINE = OnLine(X(m), Y(m), X(m + 1), Y(m + 1), returnPnt(0), returnPnt(1))
If ktONLINE = True Then
k = m
    For j = 0 To k - 1
        KC = KC + TinhKC(X(j), Y(j), X(j + 1), Y(j + 1))
    Next j
MsgBox "KC la: " & KC + TinhKC(X(k), Y(k), returnPnt(0), returnPnt(1))
End If
Next m
Wend
thoat:
'-----------------------------------------------------------------------------------------------
End Sub
Function OnLine(ByRef x1, ByRef y1, ByRef x2, ByRef y2, ByRef X, ByRef Y) As Boolean
    'A(X1, Y1):    'B(X2, Y2)
    'M(x, y) thuoc AB
    'y = fx = ax + b
    Dim A, fx As Double
    Dim dk As Boolean
    dk = False
    If (Round(x1, 4) = Round(x2, 4)) And (Round(x2, 4) = Round(X, 4)) Then
        If (y1 <= Y) And (Y <= y2) Then
            dk = True
        ElseIf (y1 >= Y) And (Y >= y2) Then
            dk = True
        End If
    ElseIf (x1 <> x2) Then
        A = ((y1 - y2) / (x1 - x2))
        fx = A * X + (y1 - x1 * A)
        If (Round(Y, 4) = Round(fx, 4)) Then
            If (x1 <= X) And (X <= x2) Then
                dk = True
            ElseIf (x1 >= X) And (X >= x2) Then
                dk = True
            End If
        End If
    End If
    OnLine = dk
End Function
'11.Ham tinh khoang cach giua 2 diem A(x1,y1) va B(x2,y2)
Public Function TinhKC(ByRef x1, ByRef y1, ByRef x2, ByRef y2) As Double
    On Error Resume Next
    Dim deltaX As Double
    Dim deltaY As Double
    deltaX = x2 - x1
    deltaY = y2 - y1
    TinhKC = (deltaX ^ 2 + deltaY ^ 2) ^ 0.5
End Function
 

[vstran 10]

Hàm này của bạn chỉ tính được khoảng dài của nhũng polyline gồm những đoạn thẳng thôi, còn của pline có đường cong thì vẫn chưa có.

[Anlee 3]

ý của bạn là: chon 1 polyline sau đó hiện lên chiều dài của từng đoạn?

bạn tham khảo đoạn mã này nhé. co gì sẽ trao đổi thêm

Sub PLO()
Dim SSetObj As AcadSelectionSet
Dim Ent As AcadEntity
Dim CD As Double
On Error Resume Next
ThisDrawing.SelectionSets("ML").Delete
Set SSetObj = ThisDrawing.SelectionSets.Add("ML")
SSetObj.SelectOnScreen
Dim Vall As Variant
Dim i As Integer
For Each Ent In SSetObj
    Vall = Ent.Explode
Next
    For i = LBound(Vall) To UBound(Vall)
        Vall(i).color = acYellow
        Vall(i).Update
        If Vall(i).Radius = 0 Then
            CD = Vall(i).Length
        Else
            CD = Vall(i).ArcLength
        End If
        MsgBox " Chieu dai doan thang la: " & Round(CD, 2)
    Next
End Sub