判断一点处直线相交形状，VBA有没有比较快的方法

zhn158

用VBA判断某一点处直线的形状，比如以下四种形状，见图。我的思路和代码如下，但运行的实在太慢，请教各位大神，有没有好的办法，多谢

某一点处直线相交的形状

我的思路是从该点附近的四个方向，分别做栏选，判断每次是不是有直线选中，然后综合栏选结果，判断直线形状：

思路

代码如下：
'输入AcadDocument对象（CadDOc），点（pnt），栏选偏移量（offset_value），形状代号（k：1，2，3，4），输出在该点处的直线是否具有形状代号代表的形状
Function criss_cross(cadDoc As AcadDocument, pnt As Variant, offset_value As Double, k As Integer) As Boolean
    Dim x As Double
    Dim y As Double

    Dim up_line As Boolean
    Dim down_line As Boolean
    Dim left_line As Boolean
    Dim right_line As Boolean

    up_line = False
    down_line = False
    left_line = False
    right_line = False

    x = pnt(0)
    y = pnt(1)
    x_left = x - offset_value
    x_right = x + offset_value
    y_up = y + offset_value
    y_down = y - offset_value

    Dim sel_line As AcadSelectionSet
    On Error Resume Next
    If Not IsNull(cadDoc.SelectionSets.Item("line1")) Then
        Set xx_sel = cadDoc.SelectionSets.Item("line1")
        xx_sel.Delete
    End If
    On Error GoTo 0
    Set sel_line = cadDoc.SelectionSets.Add("line1")
    BuildFilter pType1, pData1, 0, "LINE,LWPOLYLINE"

    Dim up_pt_list(0 To 5) As Double  
    up_pt_list(0) = x_left: up_pt_list(1) = y_up: up_pt_list(2) = 0#
    up_pt_list(3) = x_right: up_pt_list(4) = y_up: up_pt_list(5) = 0#

    Dim down_pt_list(0 To 5) As Double
    down_pt_list(0) = x_left: down_pt_list(1) = y_down: down_pt_list(2) = 0#
    down_pt_list(3) = x_right: down_pt_list(4) = y_down: down_pt_list(5) = 0#

    Dim left_pt_list(0 To 5) As Double
    left_pt_list(0) = x_left: left_pt_list(1) = y_up: left_pt_list(2) = 0#
    left_pt_list(3) = x_left: left_pt_list(4) = y_down: left_pt_list(5) = 0#

    Dim right_pt_list(0 To 5) As Double
    right_pt_list(0) = x_right: right_pt_list(1) = y_up: right_pt_list(2) = 0#
    right_pt_list(3) = x_right: right_pt_list(4) = y_down: right_pt_list(5) = 0#




    sel_line.SelectByPolygon acSelectionSetFence, up_pt_list, pType1, pData1
    If sel_line.Count > 0 Then up_line = True
    sel_line.Clear

    sel_line.SelectByPolygon acSelectionSetFence, down_pt_list, pType1, pData1
    If sel_line.Count > 0 Then down_line = True
    sel_line.Clear

    sel_line.SelectByPolygon acSelectionSetFence, left_pt_list, pType1, pData1
    If sel_line.Count > 0 Then left_line = True
    sel_line.Clear

    sel_line.SelectByPolygon acSelectionSetFence, right_pt_list, pType1, pData1
    If sel_line.Count > 0 Then right_line = True
    sel_line.Clear

    Dim dic_point_type As New Dictionary
    dic_point_type(1) = False
    dic_point_type(2) = False
    dic_point_type(3) = False
    dic_point_type(4) = False
    If up_line And left_line Then dic_point_type(1) = True
    If up_line And right_line Then dic_point_type(2) = True
    If down_line And right_line Then dic_point_type(3) = True
    If down_line And left_line Then dic_point_type(4) = True
    criss_cross = dic_point_type(k)
End Function
上面这段代码对下图的每个交点处理一遍，耗时4分钟左右：