自动绘螺丝
<P>可以绘M5--M10以内的螺丝，命令行内有提示，操作简易，</P><P>如果觉得可用，顶一下！</P>
<P>Public Sub mm()<BR>Dim ptcen As Variant<BR>Dim radius As Double<BR>Dim keyword As String<BR>On Error Resume Next<BR>'添加线型<BR>Dim ltypename As String<BR>If linetypeexist(ltypename) = False Then<BR>ltypename = "acad_iso02w100"<BR>ThisDrawing.Linetypes.Load ltypename, "acad.lin"<BR>End If</P>
<P><BR>ptcen = ThisDrawing.Utility.GetPoint(, "请选择圆心：")<BR>ThisDrawing.Utility.InitializeUserInput 0, "m5 m6 m8 m10"<BR>keyword = ThisDrawing.Utility.GetKeyword(vbCrLf & "选取螺纹类型:")<BR>If keyword = "" Then keyword = "m8"<BR>If keyword = "m5" Then<BR>addcircle ptcen, 2.1<BR>addcircle1 ptcen, 2.5</P>
<P>End If<BR>If keyword = "m6" Then<BR>addcircle ptcen, 2.5<BR>addcircle1 ptcen, 3<BR>End If<BR>If keyword = "m8" Then<BR>addcircle ptcen, 6.75 / 2<BR>addcircle1 ptcen, 4<BR>End If<BR>If keyword = "m10" Then<BR>addcircle ptcen, 4.25<BR>addcircle1 ptcen, 5</P>
<P>End If<BR>Dim objline As AcadLine<BR>Dim ptst(0 To 2) As Double<BR>Dim pten(0 To 2) As Double<BR>Dim ptst1(0 To 2) As Double<BR>Dim pten1(0 To 2) As Double<BR>ptst(0) = ptcen(0): ptst(1) = ptcen(1) - 5: ptst(2) = 0<BR>pten(0) = ptcen(0): pten(1) = ptcen(1) + 5: pten(2) = 0<BR>ptst1(0) = ptcen(0) - 5: ptst1(1) = ptcen(1): ptst1(2) = 0<BR>pten1(0) = ptcen(0) + 5: pten1(1) = ptcen(1): pten1(2) = 0</P>
<P><BR>Set objline = ThisDrawing.ModelSpace.AddLine(ptst, pten)<BR>objline.color = acBlue</P>
<P>Set objline = ThisDrawing.ModelSpace.AddLine(ptst1, pten1)<BR>objline.color = acBlue</P>
<P><BR>End Sub</P>
<P>Public Function addcircle(ByVal ptcen As Variant, ByVal radius As Double) As AcadCircle<BR>Dim objcir As AcadCircle</P>
<P>Set objcir = ThisDrawing.ModelSpace.addcircle(ptcen, radius)<BR>objcir.color = acBlue<BR>Set objcir = addcircle</P>
<P>End Function<BR>Public Function addcircle1(ByVal ptcen As Variant, ByVal radius As Double) As AcadCircle<BR>Dim objcir As AcadCircle</P>
<P>Set objcir = ThisDrawing.ModelSpace.addcircle(ptcen, radius)<BR>objcir.color = acBlue<BR>objcir.Linetype = "acad_iso02w100"<BR>objcir.LinetypeScale = 0.4<BR>Set objcir = addcircle1</P>
<P>End Function</P>
<P><BR>Public Function linetypeexist(ByVal ltypename As String) As Boolean<BR>Dim element As Object<BR>linetypeexist = False<BR>For Each element In ThisDrawing.Linetypes<BR>If element.Name = UCase(ltypename) Then<BR>linetypeexist = True<BR>Exit For<BR>End If<BR>Next</P>
<P>End Function<BR></P>
页:
[1]