粗糙度标注-(McCad---2003-11-18编的程序)

兰州人

2003-11-18编的程序见http://bbs.mjtd.com/forum.php?mod=viewthread&tid=12844
在这个粘子中采用的是匿名块技术，随后McCad又改为属性块的生成方法和属性块插入后的属性修改。
本着学习态度，对下语句进一步分析。
     Set objBlock =    ThisDrawing.Blocks.Add(InsPnt, "*U")     
    ThisDrawing.Utility.PolarPoint(InsPnt, Radians(60), 12)
    Set objBlockRef =        ThisDrawing.ModelSpace.InsertBlock(InsertPoint, blkname, Factor, Factor, Factor, Angle)   

2. Sub AddCCD()
3. Dim pnt As Variant
4. pnt =            ThisDrawing.Utility.GetPoint(, "插入点:")
5. CreateCCD 0, pnt, Radians(150), 3.5, 1
6. End Sub
8.      
9. ' 粗糙度符号标注函数
10. ' Mode为粗糙度模式，0代表表面未加工，1代表表面加工
11. ' InsertPoint为插入点位置
12. ' Angle为插入的角度
13. ' Value粗糙度值
14. ' Factor为插入的比例因子
15. Function CreateCCD(Mode As Integer, InsertPoint As Variant, Angle            As Double, Value            As String, Factor As Double)            As AcadBlockReference
16.      Dim objBlock As            AcadBlock
17.      Dim InsPnt(2)            As Double
18.      InsPnt(0)            = 0: InsPnt(1)            = 0: InsPnt(2)            = 0
19.      Set objBlock =            ThisDrawing.Blocks.Add(InsPnt, "*U")
20.      Dim Pnt2 As Variant
21.      Dim Pnt3 As Variant
22.      Dim Pnt4 As Variant
23.      Dim Pnt5 As Variant
24.      Dim Pnt6 As Variant
25.      Dim Pnt7 As Variant
26.      Dim r As Variant
27.      Pnt2 =            ThisDrawing.Utility.PolarPoint(InsPnt, Radians(60), 12)
28.      Pnt3 =            ThisDrawing.Utility.PolarPoint(InsPnt, Radians(120), 6)
29.      Pnt4 =            ThisDrawing.Utility.PolarPoint(Pnt3, 0, 6)
30.      Pnt5 =            ThisDrawing.Utility.PolarPoint(InsPnt, Radians(90), 3 / Cos(Radians(30)))
31.      Pnt6 =            ThisDrawing.Utility.PolarPoint(Pnt4, Radians(90), 0.7)
32.      Pnt7 =            ThisDrawing.Utility.PolarPoint(Pnt4, Radians(90), 4.2)
33.      r = 3 * Tan(Radians(30))
34.      Dim objLine As            AcadLine
35.      Dim objCircle As            AcadCircle
36.      Set objLine = objBlock.AddLine(InsPnt, Pnt2)
37.      objLine.color            = acByBlock
38.      Set objLine = objBlock.AddLine(InsPnt, Pnt3)
39.      objLine.color            = acByBlock
40.      If            Mode            = 1 Then
41.          Set objLine = objBlock.AddLine(Pnt3, Pnt4)
42.          objLine.color            = acByBlock
43.      ElseIf            Mode            = 0 Then
44.          Set objCircle = objBlock.AddCircle(Pnt5, r)
45.          objCircle.color            = acByBlock
46.      End If
47.      Dim objText As            AcadText
48.      If            Angle > Radians(90)            And            Angle <= Radians(270)            Then
49.          Set objText = objBlock.AddText(Value, Pnt6, 3.5)
50.          objText.Alignment            = acAlignmentTopLeft
51.          objText.Rotate InsPnt, Radians(180)
52.          objText.Move InsPnt, Pnt6
53.      Else
54.          Set objText = objBlock.AddText(Value, Pnt6, 3.5)
55.          objText.Alignment            = acAlignmentBottomRight
56.          objText.Move InsPnt, Pnt6
57.      End If
58.      objText.color            = acByBlock
59.      Dim blkname As            String
60.      blkname = objBlock.Name
61.      Dim objBlockRef As AcadBlockReference
62.      Set objBlockRef =            ThisDrawing.ModelSpace.InsertBlock(InsertPoint, blkname, Factor, Factor, Factor, Angle)
63.      Set CreateCCD = objBlockRef
64. End Function
66.      
67. Public            Function PI()            As Double
68.    PI = Atn(1)            * 4
69. End Function
71.      
72. Private            Function Degrees(Radians As Double)            As Double
73.    Degrees = Radians / PI * 180
74. End Function
76.      
77. Private            Function Radians(Degrees As Double)            As Double
78.    Radians = Degrees / 180 * PI
79. End Function

Sub AddCCD() Dim pnt As Variant pnt =            ThisDrawing.Utility.GetPoint(, "插入点:") CreateCCD 0, pnt, Radians(150), 3.5, 1 End Sub       ' 粗糙度符号标注函数 ' Mode为粗糙度模式，0代表表面未加工，1代表表面加工 ' InsertPoint为插入点位置 ' Angle为插入的角度 ' Value粗糙度值 ' Factor为插入的比例因子 Function CreateCCD(Mode As Integer, InsertPoint As Variant, Angle            As Double, Value            As String, Factor As Double)            As AcadBlockReference      Dim objBlock As            AcadBlock      Dim InsPnt(2)            As Double      InsPnt(0)            = 0: InsPnt(1)            = 0: InsPnt(2)            = 0      Set objBlock =            ThisDrawing.Blocks.Add(InsPnt, "*U")      Dim Pnt2 As Variant      Dim Pnt3 As Variant      Dim Pnt4 As Variant      Dim Pnt5 As Variant      Dim Pnt6 As Variant      Dim Pnt7 As Variant      Dim r As Variant      Pnt2 =            ThisDrawing.Utility.PolarPoint(InsPnt, Radians(60), 12)      Pnt3 =            ThisDrawing.Utility.PolarPoint(InsPnt, Radians(120), 6)      Pnt4 =            ThisDrawing.Utility.PolarPoint(Pnt3, 0, 6)      Pnt5 =            ThisDrawing.Utility.PolarPoint(InsPnt, Radians(90), 3 / Cos(Radians(30)))      Pnt6 =            ThisDrawing.Utility.PolarPoint(Pnt4, Radians(90), 0.7)      Pnt7 =            ThisDrawing.Utility.PolarPoint(Pnt4, Radians(90), 4.2)      r = 3 * Tan(Radians(30))      Dim objLine As            AcadLine      Dim objCircle As            AcadCircle      Set objLine = objBlock.AddLine(InsPnt, Pnt2)      objLine.color            = acByBlock      Set objLine = objBlock.AddLine(InsPnt, Pnt3)      objLine.color            = acByBlock      If            Mode            = 1 Then          Set objLine = objBlock.AddLine(Pnt3, Pnt4)          objLine.color            = acByBlock      ElseIf            Mode            = 0 Then          Set objCircle = objBlock.AddCircle(Pnt5, r)          objCircle.color            = acByBlock      End If      Dim objText As            AcadText      If            Angle > Radians(90)            And            Angle <= Radians(270)            Then          Set objText = objBlock.AddText(Value, Pnt6, 3.5)          objText.Alignment            = acAlignmentTopLeft          objText.Rotate InsPnt, Radians(180)          objText.Move InsPnt, Pnt6      Else          Set objText = objBlock.AddText(Value, Pnt6, 3.5)          objText.Alignment            = acAlignmentBottomRight          objText.Move InsPnt, Pnt6      End If      objText.color            = acByBlock      Dim blkname As            String      blkname = objBlock.Name      Dim objBlockRef As AcadBlockReference      Set objBlockRef =            ThisDrawing.ModelSpace.InsertBlock(InsertPoint, blkname, Factor, Factor, Factor, Angle)      Set CreateCCD = objBlockRef End Function       Public            Function PI()            As Double    PI = Atn(1)            * 4 End Function       Private            Function Degrees(Radians As Double)            As Double    Degrees = Radians / PI * 180 End Function       Private            Function Radians(Degrees As Double)            As Double    Radians = Degrees / 180 * PI End Function

兰州人

Gets the point at a specified angle and distance from a given point.

以基点为坐标，按极坐标角和定长获得另一点坐标。

RetVal = PolarPoint(Point, Angle, Distance)

ThisDrawing.Utility 取得文档的Utility 对象。

RetVal = object.AddLine(StartPoint, EndPoint)

对于直线、多义线、圆等实体，采用thisdrwing.modespace

对于promt,getpoint等采用thisdrawing.Uitility

Uitility和ModeSpace区别在什么？？？？

兰州人

2. Sub ic()
3.   On Error Resume Next
4.   Dim pnt As Variant
5.   pnt = ThisDrawing.Utility.GetPoint(, " 选择插入点：")
6.   Dim angle As Double
7.   angle = ThisDrawing.Utility.GetAngle(pnt, " 选择选择角度：")
8.   Dim txt As String
9.   txt = ThisDrawing.Utility.GetString(0, " 请输入粗糙度大小：")
10.   Dim mode As Integer
11.   mode = ThisDrawing.Utility.GetInteger(" 选择粗糙度样式[表面非加工0/表面加工1]<表面非加工>：")
12.   If Err Then
13.     mode = 0
14.     Err.Clear
15.   End If
16.   CreateCCD1 mode, pnt, angle, txt, 1
17. End Sub
18. ' 粗糙度符号标注函数
19. ' Mode为粗糙度模式，0代表表面未加工，1代表表面加工
20. ' InsertPoint为插入点
21. ' Angle为插入的角度
22. ' Value粗糙度值
23. ' Factor为插入的比例因子
24. Function CreateCCD1(mode As Integer, InsertPoint As Variant, angle As Double, Value As String, Factor As Double) As AcadBlockReference
26.   Dim objBlock As AcadBlock
27.   Dim InsPnt(2) As Double
28.   InsPnt(0) = 0: InsPnt(1) = 0: InsPnt(2) = 0
29.   Dim BlkName As String
30.   BlkName = "mc_ccd_" & mode
31.   On Error Resume Next
32.   Set objBlock = ThisDrawing.Blocks(BlkName)
33.   If Err Then Err.Clear
34.    Set objBlock = ThisDrawing.Blocks.Add(InsPnt, BlkName)
35.   Dim Pnt2 As Variant
36.   Dim Pnt3 As Variant
37.   Dim Pnt4 As Variant
38.   Dim Pnt5 As Variant
39.   Dim Pnt6 As Variant
40.   Dim r As Variant
41.   Pnt2 = ThisDrawing.Utility.PolarPoint(InsPnt, Radians(60), 12)
42.   Pnt3 = ThisDrawing.Utility.PolarPoint(InsPnt, Radians(120), 6)
43.   Pnt4 = ThisDrawing.Utility.PolarPoint(Pnt3, 0, 6)
44.   Pnt5 = ThisDrawing.Utility.PolarPoint(InsPnt, Radians(90), 3 / Cos(Radians(30)))
45.   Pnt6 = ThisDrawing.Utility.PolarPoint(Pnt4, Radians(90), 0.7)
46.   r = 3 * Tan(Radians(30))
47.   Dim objLine As AcadLine
48.   Dim objCircle As AcadCircle
49.   Set objLine = objBlock.AddLine(InsPnt, Pnt2)
50.   objLine.color = acByBlock
51.   Set objLine = objBlock.AddLine(InsPnt, Pnt3)
52.   objLine.color = acByBlock
53.   If mode = 1 Then
54.     Set objLine = objBlock.AddLine(Pnt3, Pnt4)
55.     objLine.color = acByBlock
56.   ElseIf mode = 0 Then
57.     Set objCircle = objBlock.AddCircle(Pnt5, r)
58.     objCircle.color = acByBlock
59.   End If
60.   Dim objAtt As AcadAttribute
61.   Set objAtt = objBlock.AddAttribute(3.5, acAttributeModeNormal, "粗糙度值", Pnt6, "CCD", "")
62.   objAtt.Alignment = acAlignmentBottomRight
63.   objAtt.Move InsPnt, Pnt6
64.   objAtt.color = acByBlock
65. 'End If
66.   Dim objBlockRef As AcadBlockReference
67.   Set objBlockRef = ThisDrawing.ModelSpace.InsertBlock(InsertPoint, BlkName, Factor, Factor, Factor, angle)
68.   Dim objAtts As Variant
69.   objAtts = objBlockRef.GetAttributes
70.   Dim objAttRef As AcadAttributeReference
71.   Set objAttRef = objAtts(0)
72.   objAttRef.textString = Value
73.   If angle > Radians(90) And angle <= Radians(270) Then
74.     objAttRef.Alignment = acAlignmentTopLeft
75.     objAttRef.Rotate objAttRef.TextAlignmentPoint, Radians(0)
76.   End If
77. End Function

Sub ic()   On Error Resume Next   Dim pnt As Variant   pnt = ThisDrawing.Utility.GetPoint(, " 选择插入点：")   Dim angle As Double   angle = ThisDrawing.Utility.GetAngle(pnt, " 选择选择角度：")   Dim txt As String   txt = ThisDrawing.Utility.GetString(0, " 请输入粗糙度大小：")   Dim mode As Integer   mode = ThisDrawing.Utility.GetInteger(" 选择粗糙度样式[表面非加工0/表面加工1]<表面非加工>：")   If Err Then     mode = 0     Err.Clear   End If   CreateCCD1 mode, pnt, angle, txt, 1 End Sub ' 粗糙度符号标注函数 ' Mode为粗糙度模式，0代表表面未加工，1代表表面加工 ' InsertPoint为插入点 ' Angle为插入的角度 ' Value粗糙度值 ' Factor为插入的比例因子 Function CreateCCD1(mode As Integer, InsertPoint As Variant, angle As Double, Value As String, Factor As Double) As AcadBlockReference   Dim objBlock As AcadBlock   Dim InsPnt(2) As Double   InsPnt(0) = 0: InsPnt(1) = 0: InsPnt(2) = 0   Dim BlkName As String   BlkName = "mc_ccd_" & mode   On Error Resume Next   Set objBlock = ThisDrawing.Blocks(BlkName)   If Err Then Err.Clear    Set objBlock = ThisDrawing.Blocks.Add(InsPnt, BlkName)   Dim Pnt2 As Variant   Dim Pnt3 As Variant   Dim Pnt4 As Variant   Dim Pnt5 As Variant   Dim Pnt6 As Variant   Dim r As Variant   Pnt2 = ThisDrawing.Utility.PolarPoint(InsPnt, Radians(60), 12)   Pnt3 = ThisDrawing.Utility.PolarPoint(InsPnt, Radians(120), 6)   Pnt4 = ThisDrawing.Utility.PolarPoint(Pnt3, 0, 6)   Pnt5 = ThisDrawing.Utility.PolarPoint(InsPnt, Radians(90), 3 / Cos(Radians(30)))   Pnt6 = ThisDrawing.Utility.PolarPoint(Pnt4, Radians(90), 0.7)   r = 3 * Tan(Radians(30))   Dim objLine As AcadLine   Dim objCircle As AcadCircle   Set objLine = objBlock.AddLine(InsPnt, Pnt2)   objLine.color = acByBlock   Set objLine = objBlock.AddLine(InsPnt, Pnt3)   objLine.color = acByBlock   If mode = 1 Then     Set objLine = objBlock.AddLine(Pnt3, Pnt4)     objLine.color = acByBlock   ElseIf mode = 0 Then     Set objCircle = objBlock.AddCircle(Pnt5, r)     objCircle.color = acByBlock   End If   Dim objAtt As AcadAttribute   Set objAtt = objBlock.AddAttribute(3.5, acAttributeModeNormal, "粗糙度值", Pnt6, "CCD", "")   objAtt.Alignment = acAlignmentBottomRight   objAtt.Move InsPnt, Pnt6   objAtt.color = acByBlock 'End If   Dim objBlockRef As AcadBlockReference   Set objBlockRef = ThisDrawing.ModelSpace.InsertBlock(InsertPoint, BlkName, Factor, Factor, Factor, angle)   Dim objAtts As Variant   objAtts = objBlockRef.GetAttributes   Dim objAttRef As AcadAttributeReference   Set objAttRef = objAtts(0)   objAttRef.textString = Value   If angle > Radians(90) And angle <= Radians(270) Then     objAttRef.Alignment = acAlignmentTopLeft     objAttRef.Rotate objAttRef.TextAlignmentPoint, Radians(0)   End If End Function

兰州人

Sub ic()
  On Error Resume Next
  Dim pnt As Variant
  pnt = ThisDrawing.Utility.GetPoint(, " 选择插入点：")
  Dim angle As Double
  angle = ThisDrawing.Utility.GetAngle(pnt, " 选择选择角度：")
  Dim txt As String
  txt = ThisDrawing.Utility.GetString(0, " 请输入粗糙度大小：")
  Dim mode As Integer
  mode = ThisDrawing.Utility.GetInteger(" 选择粗糙度样式[表面非加工0/表面加工1]<表面非加工>：")
  If Err Then
    mode = 0
    Err.Clear
  End If
  CreateCCD1 mode, pnt, angle, txt, 1
End Sub

' 粗糙度符号标注函数
' Mode为粗糙度模式，0代表表面未加工，1代表表面加工
' InsertPoint为插入点
' Angle为插入的角度
' Value粗糙度值
' Factor为插入的比例因子
Function CreateCCD1(mode As Integer, InsertPoint As Variant, angle As Double, Value As String, Factor As Double) As AcadBlockReference

  Dim objBlock As AcadBlock
  Dim InsPnt(2) As Double
  InsPnt(0) = 0: InsPnt(1) = 0: InsPnt(2) = 0
  Dim BlkName As String
  BlkName = "mc_ccd_" & mode
  On Error Resume Next
  Set objBlock = ThisDrawing.Blocks(BlkName)
  If Err Then Err.Clear
   Set objBlock = ThisDrawing.Blocks.Add(InsPnt, BlkName)
  Dim Pnt2 As Variant
  Dim Pnt3 As Variant
  Dim Pnt4 As Variant
  Dim Pnt5 As Variant
  Dim Pnt6 As Variant
  Dim r As Variant
  Pnt2 = ThisDrawing.Utility.PolarPoint(InsPnt, Radians(60), 12)
  Pnt3 = ThisDrawing.Utility.PolarPoint(InsPnt, Radians(120), 6)
  Pnt4 = ThisDrawing.Utility.PolarPoint(Pnt3, 0, 6)
  Pnt5 = ThisDrawing.Utility.PolarPoint(InsPnt, Radians(90), 3 / Cos(Radians(30)))
  Pnt6 = ThisDrawing.Utility.PolarPoint(Pnt4, Radians(90), 0.7)
  r = 3 * Tan(Radians(30))
  Dim objLine As AcadLine
  Dim objCircle As AcadCircle
  Set objLine = objBlock.AddLine(InsPnt, Pnt2)
  objLine.color = acByBlock
  Set objLine = objBlock.AddLine(InsPnt, Pnt3)
  objLine.color = acByBlock
  If mode = 1 Then
    Set objLine = objBlock.AddLine(Pnt3, Pnt4)
    objLine.color = acByBlock
  ElseIf mode = 0 Then
    Set objCircle = objBlock.AddCircle(Pnt5, r)
    objCircle.color = acByBlock
  End If
  Dim objAtt As AcadAttribute
  Set objAtt = objBlock.AddAttribute(3.5, acAttributeModeNormal, "粗糙度值", Pnt6, "CCD", "")
  objAtt.Alignment = acAlignmentBottomRight
  objAtt.Move InsPnt, Pnt6
  objAtt.color = acByBlock
'End If
  Dim objBlockRef As AcadBlockReference
  Set objBlockRef = ThisDrawing.ModelSpace.InsertBlock(InsertPoint, BlkName, Factor, Factor, Factor, angle)
  Dim objAtts As Variant
  objAtts = objBlockRef.GetAttributes
  Dim objAttRef As AcadAttributeReference
  Set objAttRef = objAtts(0)
  objAttRef.textString = Value
  If angle > Radians(90) And angle <= Radians(270) Then
    objAttRef.Alignment = acAlignmentTopLeft
    objAttRef.Rotate objAttRef.TextAlignmentPoint, Radians(0)
  End If
End Function

mccad

呵呵，四年前的程序都被你抓出来。

现在想想看，这个程序应该也是对VBA及AutoCAD应用的一个比较好的例子了，因为使用了各种比较少用的技术来完成。

兰州人

mccad发表于2007-11-23 22:12:00呵呵，四年前的程序都被你抓出来。现在想想看，这个程序应该也是对VBA及AutoCAD应用的一个比较好的例子了，因为使用了各种比较少用的技术来完成。

你这个程序相当实用性，我现在认真吸取你编程的思路。