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 = =