[原创]：需要就下载，全部免币！(12.28更新)

caibaobao

有没有根据已知的弧长来分割曲线（包括多义线）的程序？如果有也就不去麻烦晓东大哥了：）

自由的鱼

最初由 caibaobao 发布
[B]有没有根据已知的弧长来分割曲线（包括多义线）的程序？如果有也就不去麻烦晓东大哥了：） [/B]

这个我没有做，：）

caibaobao

最初由 自由的鱼 发布
[B]

这个我没有做，：） [/B]

烦请鱼儿编制一个吧，主要用来对弧线进行分割——平面上用的较多

自由的鱼

最初由 caibaobao 发布
[B]

烦请鱼儿编制一个吧，主要用来对弧线进行分割——平面上用的较多 [/B]

这个不需要用程序吧？把角度除一下不就分出来了嘛，呵呵


圆心角>180的可能有些问题，你改一下吧！：）

Option Explicit
Const pi = 3.1415926

Sub tt()
Dim c As AcadArc
Dim cpnt As Variant
Dim spnt As Variant
Dim epnt As Variant
Dim ent As AcadEntity
Dim pnt As Variant
Dim l1 As AcadLine
Dim l2 As AcadLine
Dim sang As Double
Dim eang As Double
Dim cz As Double
Dim dfz As Integer
dfz = InputBox("请输入等分值")
ThisDrawing.Utility.GetEntity c, pnt, "choose"
cpnt = c.center
spnt = c.StartPoint
epnt = c.EndPoint
MsgBox c.StartAngle & vbCrLf & c.EndAngle
Set l1 = ThisDrawing.ModelSpace.AddLine(cpnt, spnt)
'sang = ThisDrawing.Utility.AngleFromXAxis(cpnt, spnt)

Set l2 = ThisDrawing.ModelSpace.AddLine(cpnt, epnt)
'eang = ThisDrawing.Utility.AngleFromXAxis(cpnt, epnt)
Dim i As Integer

If c.StartAngle > c.EndAngle Then
For i = 1 To dfz
    Set l2 = ThisDrawing.ModelSpace.AddLine(cpnt, epnt)
   
    cz = (c.StartAngle - c.EndAngle)
    If cz > pi Then cz = pi * 2 - cz
    l2.Rotate cpnt, -cz / dfz * i
    'Set l2 = ThisDrawing.ModelSpace.AddLine(cpnt, epnt)
    'i = i + 1
Next

Else
For i = 1 To dfz
    Set l1 = ThisDrawing.ModelSpace.AddLine(cpnt, spnt)
    cz = (c.EndAngle - c.StartAngle)
    If cz > pi Then cz = pi * 2 - cz
    l1.Rotate cpnt, cz / dfz * i
'Set l1 = ThisDrawing.ModelSpace.AddLine(cpnt, epnt)
Next

End If




End Sub

linwenhua

cad有自带的干嘛 不用呀，如：list    area 等，

heihei008

好东西，平常不怎么样，
关键时刻显出需要

自由的鱼

最初由 linwenhua 发布
[B]cad有自带的干嘛 不用呀，如：list    area 等， [/B]

批量的时候用！

yindb

怎么加载*.fas啊？

自由的鱼

最初由 yindb 发布
[B]怎么加载*.fas啊？ [/B]

appload命令！

自由的鱼

集成所有功能吗？那要做成一个工具箱了，等以后程序多了就考虑集成，：）

自由的鱼

求交点程序：

Option Explicit

Sub ints()
On Error Resume Next
Dim Intobj As AcadEntity
Dim sset As AcadSelectionSet
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim INTPTS As Variant
Dim pnt(0 To 2) As Double
For i = 0 To ThisDrawing.SelectionSets.Count - 1
ThisDrawing.SelectionSets.Item(i).Clear
ThisDrawing.SelectionSets.Item(i).Delete
Next


Set sset = ThisDrawing.SelectionSets.Add("tt")
sset.SelectOnScreen
Dim cobj As AcadCircle

For i = 0 To sset.Count - 1
For j = i + 1 To sset.Count - 1

INTPTS = sset.Item(i).IntersectWith(sset.Item(j), acExtendNone)

If VarType(INTPTS) <> vbEmpty Then


For k = 0 To UBound(INTPTS) Step 3
pnt(0) = INTPTS(k)
pnt(1) = INTPTS(k + 1)
pnt(2) = INTPTS(k + 2)
Set cobj = ThisDrawing.ModelSpace.AddCircle(pnt, 2)
Debug.Print INTPTS(k) & " " & INTPTS(k + 1) & " " & INTPTS(k + 2)
Next
End If
Next
Next



End Sub

自由的鱼

批量注记交点坐标程序！

自由的鱼

以知两点及半径做圆！

Option Explicit

Sub addcircle()
On Error Resume Next
Dim rads As Double
Dim intpnts As Variant
rads = InputBox("输入圆半径")
Dim sset As AcadSelectionSet
Dim circleobj(1) As AcadCircle
Dim p1(0 To 2) As Double
Dim p2(0 To 2) As Double
Dim i As Integer
Dim fxd As Variant
Dim Lobj As AcadLine
Dim Tobj As AcadLine
Dim TMP As Variant
Set sset = ThisDrawing.SelectionSets.Add("c112c")
sset.SelectOnScreen
fxd = ThisDrawing.Utility.GetPoint(, "请选择方向点")
For i = 0 To 1
Set circleobj(i) = ThisDrawing.ModelSpace.addcircle(sset.Item(i).Coordinates, rads)
Next
intpnts = circleobj(0).IntersectWith(circleobj(1), acExtendNone)
circleobj(0).Delete
circleobj(1).Delete
p1(0) = intpnts(0): p1(1) = intpnts(1): p1(2) = intpnts(2)
p2(0) = intpnts(3): p2(1) = intpnts(4): p2(2) = intpnts(5)
Set Tobj = ThisDrawing.ModelSpace.AddLine(fxd, p1)
Set Lobj = ThisDrawing.ModelSpace.AddLine(p1, p2)
TMP = Tobj.IntersectWith(Lobj, acExtendNone)
If UBound(TMP) = 0 Then
Set circleobj(0) = ThisDrawing.ModelSpace.addcircle(p2, rads)
Else
Set circleobj(1) = ThisDrawing.ModelSpace.addcircle(p1, rads)
End If
Tobj.Delete
Lobj.Delete
sset.Delete
End Sub

自由的鱼

你需要哪方面的资料？我就几本书，写程序也看的都是帮助文件！VB教程网上很多的，你可以先自己搜索一下！

wcf_1117

连续偏移的命令是最实用的程序了！感谢上传！