开发平台：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"命令 清理，就能删除了