用VB6进行Autocad的二次开发(原创)

sieben

牛人!还用VB6

zzyong00

上回说到“先选择对象再执行命令”，现在牛刀小试一下
4、数值合并计算

1. Public Sub SumCalc()                                                            '数值合并计算
   
2. 
   
3.     On Error GoTo err1
   
4. 
   
5.     Dim objSset As AcadSelectionSet, objText As AcadText
   
6. 
   
7.     Set objSset = getPickFirstSel()
   
8. 
   
9.     If objSset Is Nothing Then                                                  '透明命令，支持执行前选择
   
10.         SelectLots "SSet", "Text"
    
11.         Set objSset = ThisDrawing.SelectionSets("SSet")
    
12. 
    
13.         If objSset.Count = 0 Then Exit Sub
    
14.     End If
    
15. 
    
16.     Dim sum, n As Long                                                          '和，最大有效位数
    
17. 
    
18.     For Each objText In objSset
    
19. 
    
20.         If IsNumeric(objText.TextString) Then
    
21.             If InStr(objText.TextString, ".") Then
    
22.                 If n < Len(objText.TextString) - InStr(objText.TextString, ".") Then
    
23.                     n = Len(objText.TextString) - InStr(objText.TextString, ".")
    
24.                 End If
    
25.             End If
    
26. 
    
27.             sum = sum + CDec(objText.TextString)
    
28.         Else
    
29.             ThisDrawing.Utility.Prompt objText.TextString & " 该文本不是纯数字，将不参于计算." & vbCrLf
    
30.         End If
    
31. 
    
32.     Next
    
33. 
    
34.     Dim pt1, FMT As String
    
35. 
    
36.     If n = 0 Then FMT = "0" Else FMT = "#." & String(n, "0")
    
37.     pt1 = ThisDrawing.Utility.GetPoint(, "请指定计算结果文本的插入点:")
    
38.     Set objText = ThisDrawing.ModelSpace.AddText(Format(sum, FMT), pt1, objSset.Item( _
    
39. 0).Height)
    
40. 
    
41.     Exit Sub
    
42. 
    
43. err1:
    
44.     Debug.Print Err.Description
    
45.     Err.Clear
    
46. 
    
47.     Exit Sub
    
48. 
    
49. End Sub
    

Public Sub SumCalc()                                                            '数值合并计算<br /> <br />     On Error GoTo err1<br /> <br />     Dim objSset As AcadSelectionSet, objText As AcadText<br /> <br />     Set objSset = getPickFirstSel()<br /> <br />     If objSset Is Nothing Then                                                  '透明命令，支持执行前选择<br />         SelectLots "SSet", "Text"<br />         Set objSset = ThisDrawing.SelectionSets("SSet")<br /> <br />         If objSset.Count = 0 Then Exit Sub<br />     End If<br /> <br />     Dim sum, n As Long                                                          '和，最大有效位数<br /> <br />     For Each objText In objSset<br /> <br />         If IsNumeric(objText.TextString) Then<br />             If InStr(objText.TextString, ".") Then<br />                 If n < Len(objText.TextString) - InStr(objText.TextString, ".") Then<br />                     n = Len(objText.TextString) - InStr(objText.TextString, ".")<br />                 End If<br />             End If<br /> <br />             sum = sum + CDec(objText.TextString)<br />         Else<br />             ThisDrawing.Utility.Prompt objText.TextString & " 该文本不是纯数字，将不参于计算." & vbCrLf<br />         End If<br /> <br />     Next<br /> <br />     Dim pt1, FMT As String<br /> <br />     If n = 0 Then FMT = "0" Else FMT = "#." & String(n, "0")<br />     pt1 = ThisDrawing.Utility.GetPoint(, "请指定计算结果文本的插入点:")<br />     Set objText = ThisDrawing.ModelSpace.AddText(Format(sum, FMT), pt1, objSset.Item( _<br /> 0).Height)<br /> <br />     Exit Sub<br /> <br /> err1:<br />     Debug.Print Err.Description<br />     Err.Clear<br /> <br />     Exit Sub<br /> <br /> End Sub<br />

chenshulu

chenshulu 发表于 2014-10-20 18:44
你的排图框的源码呢，

已发过二维排序的源码，在哪，
你的排图框的源码呢，还要等多久呢

zzyong00

二、对多段线的认识
多段线俗称pl线，pl线最重要的属性应该是Coordinates ，
Coordinates ：指定对象中每个顶点的坐标。Variant[变体] (双精度数组); 可读写
点数组。LightweightPolyline 对象：变体为 OCS 坐标系统的二维点数组。
另外，对于有圆弧的pl线，用方法GetBulge和SetBulge读取。
pl线的属性或方法中没有能表示每两个点之间长度的，也没有体现每一段的角度（或叫方向），圆弧段，也没有半径等。
现在，我们对其进行扩展，扩展之前，先说一点小知识，就是关于圆弧段的凸度bugle.
凸度是多段线顶点列表中选定顶点和下一顶点之间的圆弧所包含角度的 1/4 的正切值。负的凸度值表示圆弧从选定顶点到下一顶点为顺时针方向。凸度为0 表示直线段，凸度为1表示半圆。

上面的推导就不细说了，初高中数学几何问题！
有了以上各种细节知识（还有不知道的，看帮助），就实现上面说的PL线本身提供功能不足之处。
附带功能演示：

1. Option Explicit
   
2. Const PI = 3.1415926
   
3. Public Coordinate_TextHeight As Double                      '文字高
   
4. Public ratio                 As Double                      '全局比例
   
5. 
   
6. 
   
7. Public Sub ShowPLEachPartDist() '标注多线段各段长度
   
8.     On Error GoTo ToExit '打开错误陷阱
   
9.     '------------------------------------------------
   
10.     Dim objPL As AcadLWPolyline ', basePnt As Variant, blnESC As Boolean
    
11.     Dim objSset As AcadSelectionSet
    
12.     Dim objText As AcadText
    
13.     Dim InsPt As Variant  '文本插入点
    
14.     Dim dblMpt(2) As Double, dbl_NV_Angle As Double '中点，法向量角度
    
15.     Dim dblDistArr() As Double, dblMidPt() As Double, dblMidPt_NormalVector() As Double, dbl_Bugle_Radius() As Double
    
16.     Dim i As Long
    
17.     Dim objDoc As AcadDocument
    
18.     Set objDoc = ThisDrawing()
    
19.     SelectLots "MEA~PL~TMP~123", "LWPOLYLINE"
    
20.     Set objSset = objDoc.SelectionSets("MEA~PL~TMP~123")
    
21.     If objSset.Count = 0 Then Exit Sub
    
22.     For Each objPL In objSset
    
23. '如果你用，请你下载附件，花费一个币
    
24.         getPlEachPartInfo objPL, dblDistArr, dblMidPt, dblMidPt_NormalVector, dbl_Bugle_Radius
    
25.         For i = 0 To UBound(dblDistArr)
    
26.             dblMpt(0) = dblMidPt(2 * i)
    
27.             dblMpt(1) = dblMidPt(2 * i + 1)
    
28.             dbl_NV_Angle = dblMidPt_NormalVector(i)
    
29.             InsPt = objDoc.Utility.PolarPoint(dblMpt, dbl_NV_Angle, Coordinate_TextHeight * ratio)
    
30. 
    
31.             If objDoc.ActiveSpace = acPaperSpace Then   ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''图纸空间
    
32.                 Set objText = objDoc.PaperSpace.AddText(Format(CStr(Round(dblDistArr(i), 3)), "#.000"), InsPt, Coordinate_TextHeight * ratio)
    
33.             ElseIf objDoc.ActiveSpace = acModelSpace Then ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''模型空间
    
34.                 Set objText = objDoc.ModelSpace.AddText(Format(CStr(Round(dblDistArr(i), 3)), "#.000"), InsPt, Coordinate_TextHeight * ratio)
    
35.             End If
    
36. 
    
37.             objText.Alignment = acAlignmentMiddleCenter
    
38.             objText.TextAlignmentPoint = InsPt
    
39. 
    
40.             objText.Rotation = Atn(-1 / Tan(dblMidPt_NormalVector(i)))
    
41.             objText.Update
    
42.         Next i
    
43.     Next
    
44.     '------------------------------------------------
    
45.     Exit Sub
    
46.     '----------------
    
47. ToExit:
    
48.     Resume Next
    
49. End Sub
    
50. 
    
51. '二点间距离公式
    
52. Public Function GetDist2D(ByVal x1 As Double, _
    
53.     ByVal y1 As Double, _
    
54.     ByVal x2 As Double, _
    
55.     ByVal y2 As Double) As Double
    
56.     GetDist2D = Sqr((x1 - x2) ^ 2 + (y1 - y2) ^ 2)
    
57. End Function
    
58. 
    
59. 
    

Option Explicit<br /> Const PI = 3.1415926<br /> Public Coordinate_TextHeight As Double                      '文字高<br /> Public ratio                 As Double                      '全局比例<br /> <br /> <br /> Public Sub ShowPLEachPartDist() '标注多线段各段长度<br />     On Error GoTo ToExit '打开错误陷阱<br />     '------------------------------------------------<br />     Dim objPL As AcadLWPolyline ', basePnt As Variant, blnESC As Boolean<br />     Dim objSset As AcadSelectionSet<br />     Dim objText As AcadText<br />     Dim InsPt As Variant  '文本插入点<br />     Dim dblMpt(2) As Double, dbl_NV_Angle As Double '中点，法向量角度<br />     Dim dblDistArr() As Double, dblMidPt() As Double, dblMidPt_NormalVector() As Double, dbl_Bugle_Radius() As Double<br />     Dim i As Long<br />     Dim objDoc As AcadDocument<br />     Set objDoc = ThisDrawing()<br />     SelectLots "MEA~PL~TMP~123", "LWPOLYLINE"<br />     Set objSset = objDoc.SelectionSets("MEA~PL~TMP~123")<br />     If objSset.Count = 0 Then Exit Sub<br />     For Each objPL In objSset<br /> '如果你用，请你下载附件，花费一个币<br />         getPlEachPartInfo objPL, dblDistArr, dblMidPt, dblMidPt_NormalVector, dbl_Bugle_Radius<br />         For i = 0 To UBound(dblDistArr)<br />             dblMpt(0) = dblMidPt(2 * i)<br />             dblMpt(1) = dblMidPt(2 * i + 1)<br />             dbl_NV_Angle = dblMidPt_NormalVector(i)<br />             InsPt = objDoc.Utility.PolarPoint(dblMpt, dbl_NV_Angle, Coordinate_TextHeight * ratio)<br /> <br />             If objDoc.ActiveSpace = acPaperSpace Then   ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''图纸空间<br />                 Set objText = objDoc.PaperSpace.AddText(Format(CStr(Round(dblDistArr(i), 3)), "#.000"), InsPt, Coordinate_TextHeight * ratio)<br />             ElseIf objDoc.ActiveSpace = acModelSpace Then ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''模型空间<br />                 Set objText = objDoc.ModelSpace.AddText(Format(CStr(Round(dblDistArr(i), 3)), "#.000"), InsPt, Coordinate_TextHeight * ratio)<br />             End If<br /> <br />             objText.Alignment = acAlignmentMiddleCenter<br />             objText.TextAlignmentPoint = InsPt<br /> <br />             objText.Rotation = Atn(-1 / Tan(dblMidPt_NormalVector(i)))<br />             objText.Update<br />         Next i<br />     Next<br />     '------------------------------------------------<br />     Exit Sub<br />     '----------------<br /> ToExit:<br />     Resume Next<br /> End Sub<br /> <br /> '二点间距离公式<br /> Public Function GetDist2D(ByVal x1 As Double, _<br />     ByVal y1 As Double, _<br />     ByVal x2 As Double, _<br />     ByVal y2 As Double) As Double<br />     GetDist2D = Sqr((x1 - x2) ^ 2 + (y1 - y2) ^ 2)<br /> End Function<br /> <br /> <br />

取消原附件的收币，新附件增加凸度圆心坐标

qincccken

高手,在用VB6,学习一下,谢谢了

VBALISPER

向楼主学习.

阿霸jun

不错，学习了！

憨哥哥唱情歌

向楼主学习了。

vbcad

顶！
楼主的免费教程，无私分享令人敬佩！
支持！！

xiaolong1487

楼主太厉害了