发布时间 : 星期一 文章CAD_VBA更新完毕开始阅读
Dim Str1 As String
Dim StrLine As String, StrLin As String
StrLin = ThisDrawing.Application.Path + \ If Dir(StrLin) = \
MsgBox \没有找到线型文件\不能进行操作\错误\ End End If
Open StrLin For Input As #1 On Error Resume Next Do While Not EOF(1) Line Input #1, StrLine
StrLine = Trim(StrLine & \ \ ILen = Len(StrLine) If ILen > 1 Then
Str1 = Mid(StrLine, 1, 1) If Str1 = \ For I = 1 To ILen
If Mid(StrLine, I, 1) = \ Exit For End If Next
StrLine = Mid(StrLine, 2, I - 2) BL0 = False
Call LineTypeExist(StrLine, BL0) If Not BL0 Then '线型不存在则加载
ThisDrawing.Linetypes.Load StrLine, StrLin End If End If End If Loop Close #1
'*FH3_LINE,FH3_LINE ----XXX----XXX----XXX----XXX End Sub
12、文件File
'''**** File *********************************** Sub Myfile()
Dim StrFilename As String
StrFilename = \桌面\\drawing2.dwg\ ThisDrawing.Application.Documents.Open StrFilename
For I = 0 To ThisDrawing.Application.Documents.count - 1
MsgBox ThisDrawing.Application.Documents(I).Name Next
ThisDrawing.Application.Documents(\ '''注意大小写
ThisDrawing.Application.Documents(\
ThisDrawing.Application.Documents(\ ThisDrawing.Application.Documents(\End Sub
13、控制命令输入窗口SendCommand
'''****************************************************************************** Sub MySendCommand()
ThisDrawing.SendCommand Chr(13) '回车 ThisDrawing.SendCommand Chr(32) '空格 ThisDrawing.SendCommand Chr(27) 'ESC
ThisDrawing.SendCommand Chr(27) + \
ThisDrawing.SendCommand \ \ThisDrawing.SendCommand \ \End Sub
14、三维绘图
Sub yb3DMap()
Dim pt(2) As Double, z As Double Dim box As Acad3DSolid pt(0) = 500 pt(1) = 500 pt(2) = -5
Set box = ThisDrawing.ModelSpace.AddBox(pt, 1500, 1500, 10) box.color = acYellow For I = 1 To 200
pt(0) = Rnd * 1000 pt(1) = Rnd * 1000 z = Int(Rnd * 300) + 50 pt(2) = z / 2#
Set box = ThisDrawing.ModelSpace.AddBox(pt, Abs(Rnd * 100) + 20, Abs(Rnd * 100) + 20, z)
box.color = Int(Rnd * 100) Next ZoomAll
ThisDrawing.SendCommand \ ThisDrawing.SendCommand Chr(27) ThisDrawing.SendCommand \End Sub
3DMesh
Sub Example_Add3DMesh() ' This example creates a 4 X 4 polygonmesh in model space. Dim meshObj As AcadPolygonMesh Dim mSize, nSize, count As Integer Dim points(0 To 47) As Double 'Create the matrix of points
points(0) = 0: points(1) = 0: points(2) = 0 points(3) = 2: points(4) = 0: points(5) = 1 points(6) = 4: points(7) = 0: points(8) = 0 points(9) = 6: points(10) = 0: points(11) = 1 points(12) = 0: points(13) = 2: points(14) = 0 points(15) = 2: points(16) = 2: points(17) = 1 points(18) = 4: points(19) = 2: points(20) = 0 points(21) = 6: points(22) = 2: points(23) = 1 points(24) = 0: points(25) = 4: points(26) = 0 points(27) = 2: points(28) = 4: points(29) = 1 points(30) = 4: points(31) = 4: points(32) = 0 points(33) = 6: points(34) = 4: points(35) = 0 points(36) = 0: points(37) = 6: points(38) = 0 points(39) = 2: points(40) = 6: points(41) = 1 points(42) = 4: points(43) = 6: points(44) = 0 points(45) = 6: points(46) = 6: points(47) = 0 mSize = 4: nSize = 4
'creates a 3Dmesh in model space
Set meshObj = ThisDrawing.ModelSpace.Add3DMesh(mSize, nSize, points) 'Change the viewing direction of the viewport to better see the polygonmesh Dim NewDirection(0 To 2) As Double
NewDirection(0) = -1: NewDirection(1) = -1: NewDirection(2) = 1 ThisDrawing.ActiveViewport.Direction = NewDirection
ThisDrawing.ActiveViewport = ThisDrawing.ActiveViewport ZoomAll End Sub
15、块 (综合练习)
Sub MyBlock()
Dim MySS As AcadSelectionSet
Dim PntTxtSta(0 To 2) As Double, PntTxtEnd(0 To 2) As Double, DTxtAngle As Double 文字插入点,角度
' Dim MyPln As AcadLWPolyline Dim Str1 As String, Str2 As String
Dim StrLineType As String, DLineWidth As Double, LLineColor As Long '线型名称、宽度、颜色
Dim Pns As Variant, Pntsta As Variant, PntEnd As Variant, Pntln(0 To 3) As Double Dim ExpObj As Variant
Call DeleAllSelect '删除所有选择集
Set MySS = ThisDrawing.SelectionSets.Add(\ MySS.Select acSelectionSetAll If MySS.count < 1 Then Exit Sub End If
For I = MySS.count - 1 To 0 Step -1 Str1 = MySS(I).ObjectName
If Str1 = \ ExpObj = MySS(I).Explode MySS(I).Delete
For J = 0 To UBound(ExpObj)
Select Case ExpObj(J).ObjectName Case \
Pnts = ExpObj(J).Coordinates ExpObj(J).Delete Set MyPln ThisDrawing.ModelSpace.AddLightWeightPolyline(Pnts) I1 = UBound(Pnts)
For K = 0 To (I1 / 2 - 1) '宽度设定
MyPln.SetWidth K, DLineWidth, DLineWidth Next
StrLineType = \ LLineColor = 2
MyPln.LineType = StrLineType
MyPln.color = LLineColor
Case \
Pntsta = ExpObj(J).StartPoint PntEnd = ExpObj(J).EndPoint
Pntln(0) = Pntsta(0): Pntln(1) = Pntsta(1) Pntln(2) = PntEnd(0): Pntln(3) = PntEnd(1) Pnts = Pntln
ExpObj(J).Delete Set MyPln = =