工作中需要的CAD代码总结（优秀）由刀豆文库小编整理，希望给你工作、学习、生活带来方便，猜你可能喜欢“cad工作总结”。
1.遍历图层
Dim layer As AcadLayer For Each layer In ThisDrawing.Layers Next layer 2.获取指定图层
Dim CurrentLayer As AcadLayer Set CurrentLayer = ThisDrawing.Layers.Item(“层名(或序号)”)3.选择集构建(选择指定图层的文本对象)Dim acadApp As AcadApplication Dim acadDoc As AcadDocument
Private Sub Command1_Click()On Error Resume Next Set acadApp = GetObject(, “AutoCAD.Application”)If Err Then Err.Clear Set acadApp = CreateObject(“AutoCAD.Application”)End If
Set acadDoc = acadApp.ActiveDocument
Dim FType(0 To 1)As Integer Dim FData(0 To 1)As Variant
FType(0)= 0
FData(0)= “TEXT”
FType(1)= 8
FData(1)= “GCJZ”
Dim etobj As AcadSelectionSet Set etobj = acadDoc.SelectionSets.Add(“test2”)
etobj.Select acSelectionSetAll, , , FType, FData
For Each pickedobjs In etobj pickedobjs.Color = acGreen
'把选上的实体变成绿色 pickedobjs.Update Next etobj.Delete 4.遍历选择集
Dim ent As AcadEntity Dim color As New AcadAcCmColor color.ColorIndex = acRed For Each ent In ThisDrawing.ModelSpace If TypeOf ent Is AcadLine Then ent.TrueColor = color End If Next ent 5.动态创建多线段
Sub CreatePolylineBasic()On Error Resume Next Dim index As Integer index = 2
Dim pt1 As Variant pt1 = ThisDrawing.Utility.GetPoint(, “输入第一点：”)If Err Then Err.Clear Exit Sub End If
Dim ptPrevious As Variant, ptCurrent As Variant ptPrevious = pt1
NEXTPOINT: ptCurrent = ThisDrawing.Utility.GetPoint(ptPrevious, “输入下一点：”)If Err Then Err.Clear Exit Sub End If
Dim objPline As AcadLWPolyline If index = 2 Then Dim points(0 To 3)As Double points(0)= ptPrevious(0)points(1)= ptPrevious(1)points(2)= ptCurrent(0)points(3)= ptCurrent(1)Set objPline = ThisDrawing.ModelSpace.AddLightWeightPolyline(points)ElseIf index > 2 Then Dim ptvert(0 To 1)As Double ptvert(0)= ptCurrent(0)ptvert(1)= ptCurrent(1)objPline.AddVertex index-1, ptvert End If index = index + 1 ptPrevious = ptCurrent GoTo NEXTPOINT End Sub 6.获取DXF组码 直接在命令行输入(entget(car(entsel))),或者在函数中ThisDrawing.SendCommand “(entget(car(entsel)))” 7.
