开发平台：VB +CAD 2004
由于变态的客户不愿意 装CAD 2010，只用CAD 2004， 但是只有06 才支持.Net 方式，所以只能用古老的VB开发
实现功能:把几个dwg 文件，合并到一个DWG 里，然后把所有的图层 合并到一个图层，所有的颜色为白色。然后自动保存新的文件
参考资料：《VisualBasic与AutoCAD二次开发》张晋西.pdf
C#语言操作ActiveX_automation CAD二次开发实例教程.pdf
AutoCAD+ActiveX二次开发技术.pdf
基于Visual+C#的AutoCAD+开发及其在工程中的应用.pdf
Option Explicit
Dim cadapp As AcadApplication
Dim foldname As String
Private Sub Command3_Click()
\'创建一个新的文档
\'cadapp.Documents.Add
\'Call aaa
On Error Resume Next
Dim k As Integer
Dim fname As String
\'ReDim AA(List1.ListCount - 1) As String
For k = 0 To List1.ListCount - 1
fname = List1.List(k) & ".dwg"
\'AA(k) = fname
Next
\'For k = 0 To List1.ListCount - 1
\'
\'MsgBox (AA(k))
\'
\'
\'Next
Dim a As Boolean
a = IsNumeric(Mid(Text1.Text, 1, 3))
If a = True Then
MsgBox "全是数子"
Else
MsgBox "中文"
End If
Call CreateFolder
End Sub
Private Sub Command4_Click()
If List1.SelCount = 1 Then
List1.RemoveItem List1.ListIndex
End If
End Sub
Private Sub Form_Load()
On Error Resume Next
Set cadapp = GetObject(, "AutoCAD.Application")
If Err Then
Err.Clear
Set cadapp = CreateObject("AutoCAD.Application")
If Err Then
MsgBox ("没有安装CAD")
Exit Sub
End If
End If
End Sub
Private Sub Command1_Click()
Dim ssetObj As AcadSelectionSet
Set ssetObj = cadapp.ActiveDocument.SelectionSets.Add("Test1")
AppActivate cadapp.Caption
Dim FType(0) As Integer
Dim FData(0) As Variant
FType(0) = 0
FData(0) = "*text"
Dim FilterType As Variant
Dim FilterData As Variant
FilterType = FType
FilterData = FData
ssetObj.SelectOnScreen FilterType, FilterData
AppActivate 图幅下载.Caption
Dim pickedObjs As AcadEntity
For Each pickedObjs In ssetObj
pickedObjs.Highlight (True)
\' MsgBox (pickedObjs.TextString)
Dim a As Boolean
a = IsNumeric(Mid(pickedObjs.TextString, 1, 3)) And Len(pickedObjs.TextString) = 10
If a = True Then
List1.AddItem (pickedObjs.TextString)
End If
\' List1.AddItem (pickedObjs.Layer)
pickedObjs.Update
Next
ssetObj.Delete
End Sub
Private Sub Command2_Click()
Label3.Caption = "正在创建。。。。。。。"
On Error Resume Next
Dim acaddoc As AcadDocument
cadapp.Documents.Add
\'插入dwg文件
Dim fcount As Integer
fcount = List1.ListCount
Dim fk As Integer
Dim flong As Integer
flong = fcount - 1
ReDim fname(flong) As String
For fk = 0 To fcount - 1
fname(fk) = List1.List(fk)
Next
Dim findex As Integer
Label3.Caption = "正在打开文件"
For findex = 0 To fcount - 1
Dim insertedBlock As AcadBlockReference
Dim Pt_Temp_1(0 To 2) As Double
Pt_Temp_1(0) = 0
Pt_Temp_1(1) = 0
Pt_Temp_1(2) = 0
Dim Txtstr As String
Txtstr = "F:\CAD数据\" & fname(findex) & ".dwg"
If Dir(Txtstr) <> "" Then
Set insertedBlock = cadapp.ActiveDocument.ModelSpace.AttachExternalReference(Txtstr, List1.List(findex), Pt_Temp_1, 1, 1, 1, 0, False)
\' cadapp.ActiveDocument.Blocks.Item(insertedBlock.Name).Bind False
cadapp.ActiveDocument.Blocks.Item(insertedBlock.Name).Bind True
\'必须绑定为 True ,要不然不能炸开块
insertedBlock.Delete
End If
Next findex
\'炸开块
Label3.Caption = "正在显示块。。。。。。。"
For findex = 0 To fcount - 1
Dim explodeobjts As Variant
Dim Iblock As AcadBlockReference
Dim insertpoint(0 To 2) As Double
insertpoint(0) = 0
insertpoint(1) = 0
insertpoint(2) = 0
Set Iblock = cadapp.ActiveDocument.ModelSpace.InsertBlock(insertpoint, List1.List(findex), 1, 1, 1, 0)
ZoomExtents
\' MsgBox (Iblock.name)
Iblock.Explode
Iblock.Delete
cadapp.ActiveDocument.Blocks.Item(List1.List(findex)).Delete
Next findex
\'
\' Dim cadlayer As AcadLayer
\' Set cadlayer = cadapp.ActiveDocument.Layers.Item("Tk")
\'
\' cadlayer.Delete
\'删除图框
Label3.Caption = "正在删除图框。。。。。。。"
Dim TksetObj As AcadSelectionSet
Set TksetObj = cadapp.ActiveDocument.SelectionSets.Add("Tk")
Dim TkType(0) As Integer
Dim TkData(0) As Variant
TkType(0) = 8
TkData(0) = "Tk"
Dim TkFileterType As Variant
Dim TkFileterData As Variant
TkFileterType = TkType
TkFileterData = TkData
TksetObj.Select acSelectionSetAll, , , TkFileterType, TkFileterData
Dim Tkpickobject As AcadEntity
For Each Tkpickobject In TksetObj
Tkpickobject.Delete
Next
TksetObj.Delete
\'合并图层
Label3.Caption = "正在合并图层。。。。。。。"
Dim Ientity As AcadEntity
For Each Ientity In cadapp.ActiveDocument.ModelSpace
If Ientity.Layer <> "0" Then
Ientity.Layer = "0"
End If
Next Ientity
\'(command "-purge" "la" lay_name "N")
\' cadapp.ActiveDocument.SendCommand "PURGE" & vbCr & "la"&vbCr& "NET"& vbCr "N"&Chr(13)
\' Dim cadlayer As AcadLayer
\' Set cadlayer = cadapp.ActiveDocument.Layers.Item("HYD")
\'
\'
\' On Error Resume Next
\' cadlayer.Delete
\' If Err <> 0 Then
\' MsgBox "该图层不能被删除"
\' End If
\' Dim cadlayer As AcadLayers
\' \' cadapp.ActiveDocument.Layers.Count
\' Dim i As Integer
\' For i = 0 To cadapp.ActiveDocument.Layers.Count - 1
\' If cadapp.ActiveDocument.Layers.Item(i).Name <> "0" Then
\'
\' cadapp.ActiveDocument.Layers.Item(i).Delete
\'
\' End If
\'
\'
\' Next i
\' MsgBox (cadapp.ActiveDocument.Layers.Item(1).Name)
\' MsgBox (cadapp.ActiveDocument.Layers.Count)
\' explodeobjts(0).Delete
\' Dim BlockObj As AcadSelectionSet
\'
\' Set BlockObj = cadapp.ActiveDocument.SelectionSets.Add("Test2")
\'
\' Dim gpcode(0) As Integer
\' Dim datavalue(0) As Variant
\' gpcode(0) = 0
\' datavalue(0) = "INSERT"
\'
\' Dim groupcode As Variant, datacode As Variant
\' groupcode = gpcode
\' datacode = datavalue
\' BlockObj.Select acSelectionSetAll, , , groupcode, datacode
\'
\' Dim i As Integer
\' Dim ENT As AcadBlock
\' Dim Qty As Integer
\' Qty = 0
\' For i = 0 To BlockObj.Count - 1
\' Set ENT = BlockObj(i)
\' ENT.Explode
\' Qty = Qty + 1
\' Next i
\' MsgBox "炸开" & Str(Qty) & "个块！"
\'保存图形
Label3.Caption = "正在保存文件。。。。。。。"
Call CreateFolder
Dim filename As String
filename = foldname + "\" + Text1.Text + ".dwg"
cadapp.ActiveDocument.SaveAs filename
AppActivate 图幅下载.Caption
If Err Then
MsgBox Err.Description
Exit Sub
End If
MsgBox "成功！生成" + filename
Label3.Caption = "创建完毕！"
End Sub
Public Function CreateFolder()
Dim fso As New FileSystemObject
Dim riqi As String
riqi = Format(Now, "YYYY-MM-DD") + "—" + Text1.Text + "—" + Text2.Text
\'MsgBox riqi
foldname = "F:\图幅下载\小鸡鸡\" + riqi
If fso.FolderExists(foldname) Then
MsgBox "创建的文件夹已经存在", vbOKOnly, "警告"
Else
fso.CreateFolder (foldname)
If Err Then
MsgBox Err.Description
End If
\'MsgBox "创建成功"
End If
End Function
Private Sub Form_Unload(Cancel As Integer)
\'cadapp.Quit
Set cadapp = Nothing
End Sub
注意的问题：
一：以块的方式，插入dwg 文件，必须绑定为True ，要不然不能炸开。
插入后不能显示到当前modelspace,需从blocks 里从新插入才能显示
二：合并完图层 后，发现不能删除图层，可以用“PURGE"命令 清理，就能删除了