開發平台：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"命令 清理，就能刪除了