AutoCAD VBA简介及自动化介绍

视图

(Views)

集 合

包含在图形中所有的视图。

视口

(Viewports)

集合

包含在图形中所有的视口。

三

、

理

解

对

象

的

属

性

和

方

法

每一对象都关联着属性和方法。

属性描述着单个对象的外观，

而方法是一种可在单个对

象上执行的行为。当对象创建后，你就可通过属性和方法查询和编辑对象。

例如，

一个圆对象有圆心属性。

该属性以三 维世界坐标系统的坐标描述了圆的圆心。

更

改圆的圆心，你只要 简单地将该属性设定为新的坐标。圆对象也有称为偏移

(Offset)

的方法。

该方法可在相对于现存圆的指定偏移距离创建一个新的对象。

关于圆对象所有属性和方法的

列表，请参考

Au toCAD ActiveX

和

VBA

参考中的圆对象。

四

、

开

发

< br>实

例

1

、程序和文档窗口设置

Sub MyWindow()

MsgBox Title '=

杨彪绘图

01

State = acMin 'acMax

'acNorm

End Sub

Sub SetMyAcadTitle()

Dim hw&

hw = GetParent(GetParent())

SetWindowText hw,

杨彪地质编录出图子系统

Call InitialDZBL '

初始化

State = acMax

End Sub

Sub SetMyAcadWindow()

State = acNorm

Left = 100

Left = 100

= 600

= 600

End Sub

2

、视图

'''************************************ **************************************

Sub MyZoomView1()

tents

ZoomAll

End Sub

Sub MyZoomView2()

Dim VPn1

As Variant, VPn2 As V

ariant

VPn1 = nt(,

缩放窗口左下点：

VPn2 = nt(,

缩放窗口右上点：

ndow 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 = e(startPt(), EndPt())

= 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 = htWeightPolyline(Pnts)

Dim n As Integer

n = UBound(Pnts)

For K = 0 To (n / 2 - 1) '

宽度设定

th K, K / 5, Rnd * 10

Next

= 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 = yline(Pnts)

Dim n As Integer

n = UBound(Pnts)

For K = 0 To (n / 3 - 1) '

宽度设定

th K, K / 5, Rnd * 10

Next

= acYellow

ZoomAll

End Sub

‘Light

Circle

and

Hatch

Sub MyCircle()

Dim Cir(0) As AcadCircle

VPn1 = nt(,

输入插入点：

Set Cir(0) = cle(VPn1, 10#)

Set MyHatchObj = ch(0,

OuterLoop (Cir)

= 1

te

End Sub

Sub Mytext()

Dim MyTxt As AcadText

Dim StrTxt As String

Dim VPnts(2) As Double

StrTxt =

河海大学土木工程学院测绘工程系

Set MyTxt = t(StrTxt, VPnts, 100)

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

If =

MsgBox , vbInformation

Next

If LayExit Then

MsgBox

图层：

'ybNewLayer'

已经存在

!

Else

End If

(

(

Layer = (

' =

(

End Sub

Sub Ch2_IterateLayer()

'

在图层集合中循环

On Error Resume Next

Dim I As Integer

Dim msg As String

msg =

For I = 0 To - 1

msg = msg + (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 = nt(,

输入插入点：

Str1 = ing(1,

请输入点号：

KwordList =

lizeUserInput 1, KwordList

StrTF = word(

是否显 示选点的坐标？

(

是

Y)/(

否

N)

：

If UCase(StrTF) =

MsgBox

点

< br>

：

Else

End If

ity Obj1, Pnt1,

选择一个对象：

= 1

End Sub

Sub MyZoomView3()

Str1 = ing(1,

请按回车键：

aled 0.7, acZoomScaledRelative

End Sub

6

、选择集合

''

'****

SelectionSets

***************************

Sub MySelectionSets()

Dim K As Integer

Dim ssetObj As AcadSelectionSet

Dim objCollection As AcadEntity

Dim ob As AcadEntity

Dim I As Integer

For I = - 1 To 0 Step -1

ionSets(I).Delete

Next I

'

ity objCollection, Pnt1,

选择一个对象：

'

= 1

Set ssetObj = (

'

Set ssetObj = SelectionSet

acSelectionSetAll

If > 0 Then

MsgBox

选择集中对象数目

:

For Each ob In ssetObj

= acMagenta

Next

End If

End Sub

7

、栅格图像

Raster

Sub InsertRaster()

Dim a As AcadRasterImage

Dim b(2) As Double

Dim ly As AcadLayer

Dim PicFileName As String

Dim factor As Double

factor = 2#

Set ly = (

底图

PicFileName =

图片

b(0) = 100

b(1) = 100

b(2) = 0

Set

a

=

ter(PicFileName,

b,

factor, 45)

arency = True

=

底图

tents

End Sub

8

、计算面积

'''************************

计算面积

**************************************

Sub Ch3_CalculateDefinedArea()

Dim p1 As Variant

Dim p2 As Variant

Dim p3 As Variant

Dim p4 As Variant

Dim p5 As Variant

'

从用户处取得点

p1 = nt(, vbCrLf &

第一个点

:

p2 = nt(p1, vbCrLf &

第二个点

:

p3 = nt(p2, vbCrLf &

第三个点

:

p4 = nt(p3, vbCrLf &

第四个点

:

p5 = nt(p4, vbCrLf &

第五个点

:

'

由这些点创建二维多段线

Dim polyObj As AcadLWPolyline

Dim vertices(0 To 9) As Double

vertices(0) = p1(0): vertices(1) = p1(1)

vertices(2) = p2(0): vertices(3) = p2(1)

vertices(4) = p3(0): vertices(5) = p3(1)

vertices(6) = p4(0): vertices(7) = p4(1)

vertices(8) = p5(0): vertices(9) = p5(1)

Set polyObj = htWeightPolyline _

(vertices)

= True

l

'

显示多段线的面积

MsgBox

通过定义的点形成的面积为

, ,

计算定义的面积

End Sub

9

、加载菜单

‘

加载菜单