发布时间 : 2024/5/20 4:41:07 星期一 文章CAD - VBA更新完毕开始阅读

ThisDrawing.WindowState = acMax End Sub

Sub SetMyAcadWindow()

ThisDrawing.Application.WindowState = acNorm ThisDrawing.Application.WindowLeft = 100 ThisDrawing.Application.WindowLeft = 100 ThisDrawing.Application.Width = 600 ThisDrawing.Application.Height = 600 End Sub

2、视图

'''************************************************************************** Sub MyZoomView1()

ThisDrawing.Application.ZoomExtents ZoomAll End Sub

Sub MyZoomView2()

Dim VPn1 As Variant, VPn2 As Variant

VPn1 = ThisDrawing.Utility.getpoint(, \缩放窗口左下点：\ VPn2 = ThisDrawing.Utility.getpoint(, \缩放窗口右上点：\ ThisDrawing.Application.ZoomWindow VPn1, VPn2 End Sub

3、二维图形绘制 ‘addline

Sub Myaddline()

Dim ln As AcadLine

Dim startPt(2) As Double, EndPt(2) As Double startPt(0) = 0 startPt(1) = 0 startPt(0) = 100 startPt(1) = 50

Set ln = ThisDrawing.ModelSpace.AddLine(startPt(), EndPt()) ln.color = acRed ZoomAll End Sub

‘LightWeightPolyline

Sub MyLightWeightPolyline ()

Dim MyPln As AcadLWPolyline Dim Pnts(9) As Double

For I = 0 To 9

Pnts(I) = Rnd * 100 Next

' Pnts(0) = PntMin(0): Pnts(1) = PntMin(1)

' Pnts(2) = PntMin(0) + DWidth: Pnts(3) = PntMin(1)

' Pnts(4) = PntMin(0) + DWidth: Pnts(5) = PntMin(1) + DHeight ' Pnts(6) = PntMin(0): Pnts(7) = PntMin(1) + DHeight ' Pnts(8) = PntMin(0): Pnts(9) = PntMin(1)

Set MyPln = ThisDrawing.ModelSpace.AddLightWeightPolyline(Pnts)

Dim n As Integer n = UBound(Pnts)

For K = 0 To (n / 2 - 1) '宽度设定

MyPln.SetWidth K, K / 5, Rnd * 10 Next

MyPln.color = acYellow ZoomAll End Sub

‘Polyline

Sub MyPolyline()

Dim MyPln As AcadPolyline

Dim Pnts(8) As Double '''必须是3*N的数组

For I = 0 To 8

Pnts(I) = Rnd * 100 Next

Set MyPln = ThisDrawing.ModelSpace.AddPolyline(Pnts)

Dim n As Integer n = UBound(Pnts)

For K = 0 To (n / 3 - 1) '宽度设定

MyPln.SetWidth K, K / 5, Rnd * 10 Next

MyPln.color = acYellow ZoomAll End Sub

‘LightCircle and Hatch

Sub MyCircle()

Dim Cir(0) As AcadCircle

VPn1 = ThisDrawing.Utility.getpoint(, \输入插入点：\ Set Cir(0) = ThisDrawing.ModelSpace.AddCircle(VPn1, 10#)

Set MyHatchObj = ThisDrawing.ModelSpace.AddHatch(0, \ MyHatchObj.AppendOuterLoop (Cir) MyHatchObj.color = 1 MyHatchObj.Evaluate End Sub

Sub Mytext()

Dim MyTxt As AcadText Dim StrTxt As String Dim VPnts(2) As Double

StrTxt = \河海大学土木工程学院测绘工程系\ Set MyTxt = ThisDrawing.ModelSpace.AddText(StrTxt, VPnts, 100) MyTxt.color = acRed ZoomAll End Sub

Sub MyPoint()

Dim Pnts(0 To 2) As Double Dim I As Integer, J As Integer Dim MyPoint As AcadPoint Pnts(I) = 50 Pnts(I) = 60

Set MyPoint = ThisDrawing.ModelSpace.AddPoint(Pnts) ZoomAll End Sub

4、图层

Sub GetlayerName()

Dim MyLay As AcadLayer Dim BLExist As Boolean BLExist = False

Dim LayExit As Boolean LayExit = False

For Each MyLay In ThisDrawing.Layers

If MyLay.Name = \ MsgBox MyLay.Name, vbInformation Next

If LayExit Then

MsgBox \图层：'ybNewLayer' 已经存在!\ Else

ThisDrawing.Layers.Add \ End If

ThisDrawing.Layers(\ ThisDrawing.Layers(\

ThisDrawing.ActiveLayer = ThisDrawing.Layers(\ 'obj.Layer = \

ThisDrawing.Layers(\End Sub

Sub Ch2_IterateLayer() ' 在图层集合中循环 On Error Resume Next

Dim I As Integer Dim msg As String msg = \

For I = 0 To ThisDrawing.Layers.count - 1

msg = msg + ThisDrawing.Layers.Item(I).Name + vbCrLf Next

MsgBox msg End Sub

5、用户输入

'''*********************************************************************** Sub GetInput()

Dim VPn1 As Variant, StrTF As String, KwordList As String, Str1 As String Dim Obj1 As AcadObject

VPn1 = ThisDrawing.Utility.getpoint(, \输入插入点：\

Str1 = ThisDrawing.Utility.GetString(1, \请输入点号：\

KwordList = \

ThisDrawing.Utility.InitializeUserInput 1, KwordList

StrTF = ThisDrawing.Utility.GetKeyword(\是否显示选点的坐标？(是 Y)/(否 N)：\