五金模具设计之在CAD中用VBA来实现多义线的串接
五金模具设计之在CAD中用VBA来实现多义线的串接经常用CAD的人,可能多少会用VBA或LISP程序,我也不会用LISP,不过VBA还是知道一点点,对于五金模具设计来说,用这些VBA方面的东西,能加快模具设计的速度,提高设计的效率.以前在网上找了些多义线的串接的代码,希望能给大家分享一下.
主程序如下:
Sub chline() '转成多义线）
On Error GoTo errput
Dim FT As Variant, FD As Variant
CreateSSetFilter FT, FD, -4, "<or", 0, "polyline", 0, "line", 0, "lwpolyline", 0, "arc", -4, "or>"
Set Sset = CreateSSet()
Sset.SelectOnScreen FT, FD
If Sset.Count = 0 Then Exit Sub
ThisDrawing.SendCommand "_pedit" & vbCr & "M" & vbCr & _
"p" & vbCr & vbCr & "Y" & vbCr & "J" & _
vbCr & vbCr & vbCr
Exit Sub
errput:
Sset.Delete
ThisDrawing.Utility.Prompt "运行过程发生如下错误" & vbCr & Err.Number & Err.Description & vbCrLf
Err.Clear
End Sub
用到的函数如下:
Sub editpline() '转多义线
On Error GoTo errput
Set Sset = CreateSSet()
Dim FT As Variant, FD As Variant
CreateSSetFilter FT, FD, -4, "<or", 0, "polyline", 0, "line", 0, "arc", -4, "or>"
Sset.Select acSelectionSetAll, , , FT, FD
Dim Width As Double
Width = 0
' 遍历选择集中的对象
Dim ObjArc As AcadArc
Dim Ptstart, ptcenter, Ptend
Dim Radius As Double
Dim angleSt As Double, angleEn As Double
For Each ent In Sset
Select Case ent.ObjectName
Case "AcDbLine" ' 获取直线的两个端点
Ptstart = ent.Startpoint
Ptend = ent.Endpoint
Set ObjPline = AddLWPlineSeg(Ptstart, Ptend, Width)
ObjPline.LAYER = ent.LAYER: ObjPline.Color = ent.Color
ObjPline.Linetype = ent.Linetype
ent.Delete
Case "AcDbArc" ' 获取圆弧的圆心、半径、起始角度和终止角度
ptcenter = ent.Center
Radius = ent.Radius
angleSt = ent.StartAngle
angleEn = ent.EndAngle
Set ObjPline = AddLWPlineArc(ptcenter, Radius, angleSt, angleEn, Width)
ObjPline.LAYER = ent.LAYER: ObjPline.Color = ent.Color
ObjPline.Linetype = ent.Linetype
ent.Delete
Case "AcDb2dPolyline", "AcDb3dPolyline", "AcDbPolyline"
ent.ConstantWidth = Width
ent.Update
End Select
Next ent
Sset.Clear
' 选择实体，并将选择集中的数据转换成可在AutoLISP中使用的形式
Sset.SelectOnScreen
If Sset.Count = 0 Then
ThisDrawing.Utility.Prompt "您未选取任何图素,请重新开始!" & vbCrLf
Exit Sub
End If
Dim det As String
det = axSSet2lspEnts(Sset)
' 使用SendCommand听后方法完成连接操作
ThisDrawing.SendCommand "_PEDIT" & vbCr & "M" & vbCr & det & vbCr & vbCr & "J" & vbCr & vbCr & vbCr
ThisDrawing.Utility.Prompt "多线段转换结束!" & vbCrLf
Exit Sub
errput:
Sset.Delete
ThisDrawing.Utility.Prompt "运行过程发生如下错误" & vbCr & Err.Number & Err.Description & vbCrLf
Err.Clear
End Sub
'创建轻量多段线（只有两个顶点的直线多段线）
Public Function AddLWPlineSeg(ByVal Ptst As Variant, ByVal Pten As Variant, ByVal Width As Double) As AcadLWPolyline
Dim ptarr(0 To 3) As Double
ptarr(0) = Ptst(0)
ptarr(1) = Ptst(1)
ptarr(2) = Pten(0)
ptarr(3) = Pten(1)
Set ObjPline = ThisDrawing.ModelSpace.AddLightWeightPolyline(ptarr)
ObjPline.ConstantWidth = Width
ObjPline.Update
Set AddLWPlineSeg = ObjPline
End Function
' 创建一个圆弧段
Public Function AddLWPlineArc(ByVal Ptcen As Variant, ByVal Radius As Double, ByVal angleSt As Double, ByVal angleEn As Double, _
ByVal Width As Double) As AcadLWPolyline
Dim ptarr(0 To 3) As Double
ptarr(0) = Ptcen(0) + Radius * Cos(angleSt)
ptarr(1) = Ptcen(1) + Radius * Sin(angleSt)
ptarr(2) = Ptcen(0) + Radius * Cos(angleEn)
ptarr(3) = Ptcen(1) + Radius * Sin(angleEn)
Set ObjPline = ThisDrawing.ModelSpace.AddLightWeightPolyline(ptarr)
ObjPline.ConstantWidth = Width
' 如果圆弧通过了0度
If angleEn < angleSt Then
angleSt = angleSt - 8 * Atn(1)
End If
' 注意凸度的含义
ObjPline.SetBulge 0, Tan((angleEn - angleSt) / 4)
ObjPline.SetBulge 1, 0
ObjPline.Update
Set AddLWPlineArc = ObjPline
End Function
' 创建一个圆
Public Function AddLWPlineCircle(ByVal Ptcen As Variant, ByVal Radius As Double, ByVal Width As Double) As AcadLWPolyline
Dim ptarr(0 To 5) As Double
ptarr(0) = Ptcen(0) + Radius
ptarr(1) = Ptcen(1)
ptarr(2) = Ptcen(0) - Radius
ptarr(3) = Ptcen(1)
ptarr(4) = Ptcen(0) + Radius
ptarr(5) = Ptcen(1)
Set ObjPline = ThisDrawing.ModelSpace.AddLightWeightPolyline(ptarr)
ObjPline.ConstantWidth = Width
' 将各顶点的凸度均设置为1
ObjPline.SetBulge 0, 1
ObjPline.SetBulge 1, 1
ObjPline.SetBulge 2, 1
ObjPline.Closed = True
ObjPline.Update
Set AddLWPlineCircle = ObjPline
End Function
' 获得多段线的节点数
Public Function GetVertexCount(ByVal ObjPline As AcadEntity) As Long
If TypeOf ObjPline Is AcadLWPolyline Then
GetVertexCount = (UBound(ObjPline.Coordinates) + 1) / 2
ElseIf TypeOf ObjPline Is AcadPolyline Then
GetVertexCount = (UBound(ObjPline.Coordinates) + 1) / 3
End If
End Function
' 获得多段线的凸度数组
Public Function GetAllBulges(ByVal OBJPOLY As AcadEntity) As Collection
If TypeOf OBJPOLY Is AcadLWPolyline Or TypeOf OBJPOLY Is AcadPolyline Then
Dim bulgeCollection As New Collection
Dim I As Long
For I = 0 To GetVertexCount(OBJPOLY) - 1
bulgeCollection.Add OBJPOLY.GetBulge(I)
Next I
Set GetAllBulges = bulgeCollection
Else
MsgBox "objPoly不是多段线！"
End If
End Function
' 反转集合中的元素，并将凸度不为0的元素取相反数
Public Function RevCollection(ByVal bulgeCollection As Collection) As Collection
Dim newCollection As New Collection
Dim I As Long
For I = 1 To bulgeCollection.Count
Dim bulge As Double
bulge = bulgeCollection.Item(bulgeCollection.Count + 1 - I)
If bulge <> 0 Then
newCollection.Add -bulgeCollection.Item(bulgeCollection.Count + 1 - I)
Else
newCollection.Add 0
End If
Next I
Set RevCollection = newCollection
End Function
' 测试获得节点数量的函数
Public Sub TestVertexCount()
Dim objSelect As Object
Dim ptPick As Variant
ThisDrawing.Utility.GetEntity objSelect, ptPick, "选择多段线:"
If TypeOf objSelect Is AcadLWPolyline Then
MsgBox GetVertexCount(objSelect)
End If
End Sub
' 转换多个图元的函数
Public Function axSSet2lspEnts(ByVal Sset As AcadSelectionSet) As String
If Sset.Count = 0 Then Exit Function
Dim entHandle As String
Dim strEnts As String
entHandle = Sset.Item(0).Handle
strEnts = "(handent " & Chr(34) & entHandle & Chr(34) & ")"
If Sset.Count > 1 Then
Dim I As Integer
For I = 1 To Sset.Count - 1
entHandle = Sset.Item(I).Handle
strEnts = strEnts & vbCr & "(handent " & Chr(34) & entHandle & Chr(34) & ")"
Next I
End If
axSSet2lspEnts = strEnts
End Function
'转换双元表的函数
Public Function GetDoubleEntTable(entObj As AcadEntity, pnt As Variant) As String
Dim entHandle As String
entHandle = entObj.Handle
GetDoubleEntTable = "(list(handent " & Chr(34) & entHandle & Chr(34) & _
")(list " & STR(pnt(0)) & STR(pnt(1)) & STR(pnt(2)) & "))"
End Function
Public Function axPoint2lspPoint(pnt As Variant) As String
axPoint2lspPoint = pnt(0) & "," & pnt(1) & "," & pnt(2)
End Function
'转换图元函数
Public Function axEnt2lspEntsign(entObj As AcadEntity) As String
Dim entHandle As String
entHandle = entObj.Handle
axEnt2lspEntsign = "(handent " & Chr(34) & entHandle & Chr(34) & ")"
End Function
Sub Fgt() '挂台绘制
On Error GoTo errput
Dim PL1 As AcadLWPolyline, Line5 As AcadLine, Ptst As Variant, Pten As Variant
Dim Entity As AcadEntity, PT As Variant, Lengh As String, hei As String
Dim L As Double, W As Double
Lengh = ThisDrawing.Utility.GetString(1, "请输入挂台长度:")
L = Cdou(Lengh)
hei = ThisDrawing.Utility.GetString(True, "请输入挂台宽度(Enter为1.5mm):")
If hei = "" Then hei = "1.5"
W = Cdou(hei)
Redo:
On Error Resume Next
ThisDrawing.Utility.GetEntity Entity, PT, "请拾取图素:"
If Err <> 0 Then Exit Sub
If TypeOf Entity Is AcadLWPolyline Or TypeOf Entity Is AcadPolyline Then
Ptst = ThisDrawing.Utility.GetPoint(, "请拾取要绘制挂台的直线端点:")
Pten = ThisDrawing.Utility.GetPoint(, "请拾取要绘制挂台的直线的另一端点:")
Set Line5 = DrawLine(Ptst, Pten, Entity.LAYER, "Hidden2")
GoTo Redo
ElseIf TypeOf Entity Is AcadLine Then
Dim ent As AcadLine
Set ent = Entity
Else
MsgBox "不能对此图素进行挂台操作，退出！"
Exit Sub
End If
Dim Pt1 As Variant
If ent.Angle > 3.1415926535897 Then
Pt1 = ent.Startpoint: ent.Startpoint = ent.Endpoint: ent.Endpoint = Pt1
End If
PT = ThisDrawing.Utility.GetPoint(, "请拾取方向点:")
Dim mid As Variant
mid = GetPoint(ent.Startpoint, (ent.Endpoint(0) - ent.Startpoint(0)) / 2, (ent.Endpoint(1) - ent.Startpoint(1)) / 2)
Dim pl As AcadLWPolyline
If PT(0) > mid(0) Then
Set pl = AddRect(GetPoint(mid, -L / 2, -W / 2), GetPoint(mid, L / 2, 0), ent.LAYER)
pl.Rotate mid, ent.Angle
End If
If PT(0) < mid(0) Then
Set pl = AddRect(GetPoint(mid, -L / 2, -W / 2), GetPoint(mid, L / 2, 0), ent.LAYER)
pl.Rotate mid, ent.Angle + 3.1415926535897
End If
If Line5 Is Not Empty Then Line5.Delete
GoTo Redo
Exit Sub
errput:
MsgBox "运行过程发生如下错误" & vbCr & Err.Number & Err.Description
Err.Clear
End Sub
Public Sub Fys() '引线绘制
On Error GoTo errput
Dim strradius As String, Radius As Double
strradius = ThisDrawing.Utility.GetString(1, "请输入引线孔之孔径:")
Radius = Cdou(strradius)
Redo:
Dim PT As Variant, Pt1 As Variant
On Error Resume Next
PT = ThisDrawing.Utility.GetPoint(, "请拾取基准点:")
If Err <> 0 Then Exit Sub
If CheckKey(VK_ESCAPE) = True Then Exit Sub
Pt1 = ThisDrawing.Utility.GetPoint(, "请拾取方向点:")
If Err <> 0 Then Exit Sub
If CheckKey(VK_ESCAPE) = True Then Exit Sub
If Abs(Pt1(0) - PT(0)) > Abs(Pt1(1) - PT(1)) Then
If Pt1(0) > PT(0) Then
Set Objcir = Drawcircle(GetPoint(PT, 5, 0), Radius, ThisDrawing.ActiveLayer.Name, , acBlue)
Else
Set Objcir = Drawcircle(GetPoint(PT, -5, 0), Radius, ThisDrawing.ActiveLayer.Name, , acBlue)
End If
Else
If Pt1(1) > PT(1) Then
Set Objcir = Drawcircle(GetPoint(PT, 0, 5), Radius, ThisDrawing.ActiveLayer.Name, , acBlue)
Else
Set Objcir = Drawcircle(GetPoint(PT, 0, -5), Radius, ThisDrawing.ActiveLayer.Name, , acBlue)
End If
End If
GoTo Redo
Exit Sub
errput:
MsgBox "运行过程发生如下错误" & vbCr & Err.Number & Err.Description
Err.Clear
End Sub
'判断多线段的方向
Public Function isfront(ByVal pl As AcadLWPolyline) As Boolean
Dim PLW As AcadLWPolyline
On Error GoTo errput
pl.Offset 0.03
Set PLW = ThisDrawing.ModelSpace.Item(ThisDrawing.ModelSpace.Count - 1)
If PLW.Area < pl.Area Then
isfront = True
Else
isfront = False
End If
PLW.Delete
Exit Function
errput:
ThisDrawing.Utility.Prompt "运行过程发生如下错误" & vbCr & Err.Number & Err.Description & vbCrLf
Err.Clear
End Function
' 以闭合多段线作为边界进行选择
Public Sub SelectByPoly(ByRef Sset As AcadSelectionSet, ByVal ObjPline As AcadLWPolyline, ByVal mode As AcSelect)
If ObjPline.Closed = False Then MsgBox "作为边界的多段线不闭合！": Exit Sub
' 将轻量多段线的坐标输入到点数组中
Dim pointArrs() As Double
ReDim pointArrs((UBound(ObjPline.Coordinates) + 1) * 3 / 2 - 1)
Dim I As Integer
For I = 0 To ((UBound(ObjPline.Coordinates) + 1) / 2 - 1)
pointArrs(3 * I) = ObjPline.Coordinates(2 * I)
pointArrs(3 * I + 1) = ObjPline.Coordinates(2 * I + 1)
pointArrs(3 * I + 2) = 0
Next I
Sset.SelectByPolygon mode, pointArrs
End Sub
'合并点到点组
Public Function MergePoints(Flatten As Boolean, points) As Variant
Dim Retval() As Double, PT
Dim max As Long, I As Long, J As Long
max = -1
For I = LBound(points) To UBound(points)
PT = points(I)
For J = LBound(PT) To IIf(Flatten, UBound(PT) - 1, UBound(PT))
max = max + 1
ReDim Preserve Retval(0 To max)
Retval(max) = PT(J)
Next
Next
MergePoints = Retval
End Function
将上面的代码放到你的模板上,运行chline这个主函数就能实现多义线的串接了!
页:
[1]