自动绘螺丝

bsirhell

可以绘M5--M10以内的螺丝，命令行内有提示，操作简易，

如果觉得可用，顶一下！

Public Sub mm()
Dim ptcen As Variant
Dim radius As Double
Dim keyword As String
On Error Resume Next
'添加线型
Dim ltypename As String
If linetypeexist(ltypename) = False Then
ltypename = "acad_iso02w100"
ThisDrawing.Linetypes.Load ltypename, "acad.lin"
End If

ptcen = ThisDrawing.Utility.GetPoint(, "请选择圆心：")
ThisDrawing.Utility.InitializeUserInput 0, "m5 m6 m8 m10"
keyword = ThisDrawing.Utility.GetKeyword(vbCrLf & "选取螺纹类型[M5(m5)/M6(m6)/M8(m8)/M10(m10)]:")
If keyword = "" Then keyword = "m8"
If keyword = "m5" Then
addcircle ptcen, 2.1
addcircle1 ptcen, 2.5

End If
If keyword = "m6" Then
addcircle ptcen, 2.5
addcircle1 ptcen, 3
End If
If keyword = "m8" Then
addcircle ptcen, 6.75 / 2
addcircle1 ptcen, 4
End If
If keyword = "m10" Then
addcircle ptcen, 4.25
addcircle1 ptcen, 5

End If
Dim objline As AcadLine
Dim ptst(0 To 2) As Double
Dim pten(0 To 2) As Double
Dim ptst1(0 To 2) As Double
Dim pten1(0 To 2) As Double
ptst(0) = ptcen(0): ptst(1) = ptcen(1) - 5: ptst(2) = 0
pten(0) = ptcen(0): pten(1) = ptcen(1) + 5: pten(2) = 0
ptst1(0) = ptcen(0) - 5: ptst1(1) = ptcen(1): ptst1(2) = 0
pten1(0) = ptcen(0) + 5: pten1(1) = ptcen(1): pten1(2) = 0

Set objline = ThisDrawing.ModelSpace.AddLine(ptst, pten)
objline.color = acBlue

Set objline = ThisDrawing.ModelSpace.AddLine(ptst1, pten1)
objline.color = acBlue

End Sub

Public Function addcircle(ByVal ptcen As Variant, ByVal radius As Double) As AcadCircle
Dim objcir As AcadCircle

Set objcir = ThisDrawing.ModelSpace.addcircle(ptcen, radius)
objcir.color = acBlue
Set objcir = addcircle

End Function
Public Function addcircle1(ByVal ptcen As Variant, ByVal radius As Double) As AcadCircle
Dim objcir As AcadCircle

Set objcir = ThisDrawing.ModelSpace.addcircle(ptcen, radius)
objcir.color = acBlue
objcir.Linetype = "acad_iso02w100"
objcir.LinetypeScale = 0.4
Set objcir = addcircle1

End Function

Public Function linetypeexist(ByVal ltypename As String) As Boolean
Dim element As Object
linetypeexist = False
For Each element In ThisDrawing.Linetypes
If element.Name = UCase(ltypename) Then
linetypeexist = True
Exit For
End If
Next

End Function