任意两个点单坡，按此两点算坡任意内插点(黄点)

yjycad

任意两个点单坡，按此两点算坡任意内插点lsp,谢谢。

ljq

yjycad 发表于 2018-1-2 13:51
你好，这个内插数据倒是正确的，怎么像cass一样直接形成点啊？谢谢！

不会cass，不懂你说的形成点是什么意思？n年前用过一次cass打网程序，感觉很差就再没有使用过。

yjycad

哪位大师帮帮忙！谢谢

ljq

Sub qiu_gc()
    Dim a1 As Double, b1 As Double, c1 As Double
    Dim a2 As Double, b2 As Double, c2 As Double
    Dim x1 As Double, y1 As Double, z1 As Double
    Dim x2 As Double, y2 As Double, z2 As Double
    Dim x0 As Double, y0 As Double, z0 As Double
    Dim x As Double, y As Double, ee As Double
    Dim dlt As Double, dx As Double, dy As Double
   
    ee = 0.000001
    p1 = thisdrawing.Utility.GetPoint(, "第一点：")
    p2 = thisdrawing.Utility.GetPoint(p1, "第二点：")
    x1 = p1(0): y1 = p1(1): z1 = 200
    x2 = p2(0): y2 = p2(1): z2 = 100
    '直线方程系数
    a1 = y2 - y1
    b1 = x1 - x2
    c1 = -a1 * x1 - b1 * y1
    '求任意点标高
    p0 = thisdrawing.Utility.GetPoint(, "任意点：")
    x0 = p0(0): y0 = p0(1)
    '垂线系数
    a2 = b1
    b2 = -a1
    c2 = -a2 * x0 - b2 * y0
    '求垂足
    dlt = a1 * b2 - a2 * b1
    dx = c1 * b2 - c2 * b1
    dy = a1 * c2 - a2 * c1
    If (Abs(dlt) < ee) Then
        If (Abs(dx) < ee) And (Abs(dy) < ee) Then
            x = 1E+20
            y = 1E+20
        Else
            x = -1E+20
            y = -1E+20
        End If
    Else
        x = -dx / dlt
        y = -dy / dlt
    End If
    '求z0=z
    If x1 = x2 Then
        bl = (y - y1) / (y1 - y2)
        z = z1 + bl * (z1 - z2)
    Else
        bl = (x - x1) / (x1 - x2)
        z = z1 + bl * (z1 - z2)
    End If
    'Debug.Print x, y, z
    MsgBox "标高=" & Format(z, "##0.0000")
End Sub

yjycad

ljq 发表于 2017-12-31 10:55
Sub qiu_gc()
    Dim a1 As Double, b1 As Double, c1 As Double
    Dim a2 As Double, b2 As Double,  ...

你好，这个内插数据倒是正确的，怎么像cass一样直接形成点啊？谢谢！

yjycad

还有没有哪个大师帮帮忙，谢谢！！！

yjycad

yjycad 发表于 2018-1-12 00:58
还有没有哪个大师帮帮忙，谢谢！！！

cass点文件

ljq

Sub pt_cass()
    Dim ss As AcadSelectionSet, point As AcadPoint
    Dim x As Double, y As Double, z As Double
    Set ss = thisdrawing.SelectionSets.Add("dsddsws")
    ss.SelectOnScreen
    If ss.Count = 0 Then ss.Delete: Exit Sub
    Open "d:\cass_pt.dat" For Output As #1
    For Each point In ss
        i = i + 1
        x = Format(point.Coordinates(0), "###0.000")
        y = Format(point.Coordinates(1), "###0.000")
        z = Format(point.Coordinates(2), "###0.000")
        Write #1, i, , x, y, z
    Next point
    ss.Delete
    Close #1
End Sub

ljq

在前面插值程序中，加入2个语句，生成插入点。当所有插值完毕后，采用上面程序生成点文件。
    'Debug.Print x, y, z
    p0(0) = x: p0(1) = y: p0(2) = z
    thisdrawing.ModelSpace.AddPoint pt0
    MsgBox "标高=" & Format(z, "##0.0000")

13648893846

这是我写的第一个http://www.mjtd.com/forum.php?mod=viewthread&tid=175628&highlight=%C7%F3%D0%B1%C3%E6&mobile=2