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)£º\