cad 二次开发（一）

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