利用vb程序控制cad划矩形

先在 工程－引用 里面增加 aucocad类型库然后写代码如下：

Private Sub Command1_Click()

Dim p1(2) As Double, p2(2) As Double, p3(2) As Double

Dim acad As AcadApplication

Dim adoc As AcadDocument

Dim aline As acadline

Dim dima As AcadDimAligned

Set acad = CreateObject("autocad.application.16")

acad.Visible = True

Set adoc = acad.Documents.Add

p1(0) = 100: p1(1) = 100: p1(2) = 0

p2(0) = 1000: p2(1) = 1000: p2(2) = 0

p3(0) = 500: p3(1) = 520: p3(2) = 0

Set aline = adoc.ModelSpace.addline(p1, p2)

aline.Color = acblue

Set dima = adoc.ModelSpace.AddDimAligned(p1, p2, p3)

dima.TextHeight = 15

dima.TextColor = acGreen

dima.ArrowheadSize = 10

End Sub

Private Sub Command1_Click()

'首先引用 acad 2009 Object Library类型库

Dim myAcadApp As AutoCAD.AcadApplication, activeDoc As AutoCAD.AcadDocument, acMS As AutoCAD.AcadModelSpace

On Error Resume Next

Set myAcadApp = GetObject(, "Autocad.Application") '检查AutoCAD是否已经打开

If Err <>0 Then '没有打开

Err.Clear

Set myAcadApp = CreateObject("Autocad.Application") '打开CAD

If Err Then

MsgBox Err.Number &":" &Err.Description '打开失败

Exit Sub

End If

End If

On Error GoTo prcERR

myAcadApp.Visible = True '显示CAD

Set activeDoc = myAcadApp.ActiveDocument

Dim startPoint(0 To 2) As Double

Dim endPoint(0 To 2) As Double

Dim LineObj As AcadLine'如果画图时出错，改为Dim LineObj As Object

startPoint(0) = 0: startPoint(1) = 0: startPoint(2) = 0

endPoint(0) = 30: endPoint(1) = 20: endPoint(2) = 0

Set LineObj = activeDoc.ModelSpace.AddLine(startPoint, endPoint) '画线

prcExit:

Set activeDoc = Nothing

Set myAcadApp = Nothing

Exit Sub

prcERR:

MsgBox Err.Number &":" &Err.Description, vbCritical, "错误"

Resume prcExit

End Sub

其实就是控制CAD的过程，思路如下：

一、在VB中建一个窗体，在上面放上一个按钮A，放一个文本框，用来存放想要填充的图案名称（PAT文件名）

二、按钮A的编程：

1、调用API找到CAD类，

2、向CAD发出指令，---选择图元的指令是UTILITY下边的GETENTITY，，然后用填充指令，在MODELSPACE下边的AddHatch，，

3、以上所说的指令的详细用法请参阅CAD帮助文件

---