粗糙度标注-(McCad-2003-11-18编的程序) - VBA/VB/ActiveX/API 编程技术 - AutoCAD论坛 - 明经CAD社区

兰州人 发表于 2007-11-22 13:50:00

粗糙度标注-(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)
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

兰州人 发表于 2007-11-22 15:25:00

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.UitilityUitility和ModeSpace区别在什么？？？？

兰州人 发表于 2007-11-22 16:51:00

本帖最后由作者于 2007-11-22 19:15:00 编辑

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

兰州人 发表于 2007-11-22 16:52:00

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 发表于 2007-11-23 22:12:00

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

兰州人 发表于 2007-11-28 08:49:00

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

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

页: [1]

明经CAD社区's Archiver

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