[求助]：求教ahlzl斑竹 已知弧长，拱高怎样画圆弧

157

ahlzl斑竹 以前您写了一个已知弧长和弦长在CAD中做图程序。现在能否帮忙写一个已知弧长、拱高在CAD中做图程序。谢谢！

ahlzl

这个试试，有问题我再修改。
[php]
Sub ABC()

    Dim x As Double, xx As Double, fx As Double, flx As Double
    Dim H As Double, S As Double, R As Double, n As Integer
    Dim Point As Variant
    Const pi = 3.1415926535897
   
    Point = ThisDrawing.Utility.GetPoint(, "请输入圆弧的中心点：")
    H = ThisDrawing.Utility.GetDistance(Point, "请输入圆弧的拱高：")
    S = ThisDrawing.Utility.GetDistance(Point, "请输入圆弧的弧长：")
   
    If H <= 0 Or S <= 0 Then
        MsgBox ("弧长和拱高必须为正数，请重新输入！")
        Exit Sub
    End If
   
    If S < 2 * pi * R Then
        MsgBox ("您输入的数据不无法绘制出圆弧！")
        Exit Sub
    End If
   
    n = 0
    x = 1
    xx = x
   
    Do
    x = xx
    fx = (S / x) * (1 - Cos(x / 2)) - H
    flx = 0.5 * S * Sin(x / 2) / x - (1 - Cos(x / 2)) * S / x ^ 2
    xx = x - fx / flx
    n = n + 1
   
    If n = 100 Then
        MsgBox ("您输入的数据不无法绘制出圆弧！")
        Exit Sub
    End If
   
    Loop While Abs(xx - x) > 0.0000000001
   
    R = S / xx
    Debug.Print n
    Dim ARC As AcadArc
    Dim CenPoint(2) As Double
    CenPoint(0) = Point(0): CenPoint(1) = Point(1) - H: CenPoint(2) = Point(2)
    Set ARC = ThisDrawing.ModelSpace.AddArc(CenPoint, R, (pi - xx) / 2, (pi + xx) / 2)
   
    On Error Resume Next
    ang = ThisDrawing.Utility.GetAngle(Point, "请输入圆弧要旋转的角度 <0>：")
    If Err Then
        Err.Clear
        ang = 0
    End If
   
    ARC.Rotate Point, ang
    ARC.Update
End Sub[/php]

cwren

请问这个程序怎么用啊,要输入什么命令

ahlzl

最初由 cwren 发布
[B]请问这个程序怎么用啊,要输入什么命令 [/B]

下载附件，解压。用VBALOAD命令加载；再用VBARUN命令运行。还可以用VBAMAN命令——加载——启用宏——宏——运行。

157

ahlzl斑竹：
   非常好！谢谢！

1-5-7

ahlzl 发表于 2005-1-8 09:27
这个试试，有问题我再修改。

Sub ABC()

ahlzl斑竹，这个程序无法下载了。能重新修复一下吗？
谢谢！

linlisos

ahlzl 发表于 2005-1-8 09:27
这个试试，有问题我再修改。

Sub ABC()

大佬，有没有lsp版本的？