<p><font style="BACKGROUND-COLOR: #f3f3f3;">Option Explicit<br/>Public acadapp As AcadApplication<br/>Public AcadDocs As AcadDocuments<br/>Public MoSpace As AcadModelSpace<br/>Public AcadDoc As AcadDocument<br/>Public MainForm As VB.Form</font></p><p>Public i As Integer</p><p>'连接AutoCAD子函数<br/>Public Sub AutoCAD_Appliaction()<br/> On Error Resume Next<br/> Dim Thisdrawing As AcadDocument<br/> Set acadapp = GetObject(, "AutoCAD.Application.16")<br/> If Err Then<br/> Err.Clear<br/> Set acadapp = CreateObject("AutoCAD.Application.16")<br/> If Err Then<br/> MainForm.Visible = False<br/> MsgBox Err.Description<br/> MainForm.Visible = True<br/> Exit Sub<br/> End If<br/> Else<br/> If acadapp.Documents.Count >= 1 Then<br/> For i = acadapp.Documents.Count To 1 Step -1<br/> Set Thisdrawing = acadapp.Documents.Item(i - 1)<br/> If Not acadapp.ActiveDocument.Saved Then<br/> If MsgBox("是否要保存以前打开的.dwg文件？", vbYesNo) = vbYes Then<br/> acadapp.ActiveDocument.Save<br/> Else<br/> acadapp.ActiveDocument.Close (False)<br/> End If<br/> End If<br/> Thisdrawing.Close<br/> Next<br/> End If<br/> End If<br/> Set Thisdrawing = Nothing<br/> acadapp.Visible = True<br/> acadapp.WindowState = acMax<br/>End Sub</p><p>请指教！谢谢了！</p> <p>看了你的代码，还不太好说：</p><p>1.acadapp本身是AcadApplication对象，就不能用acadapp.Application，而需要直接acadapp.Documents("文件名")。</p><p>2. 新图形 Dim objNewDoc As AcadDocument 下面的那句语句，应该是Set objNewDoc ...。</p><p>3.你写的VB与AutoCAD连接的代码，判断如果ACAD是打开的话，则关闭所有已经打开的文档，我不知道这点有没有影响，因为没看到你中间的其它代码，是不是自己手动打开你需要的文档还是其它。</p><p>4.你的图库是否就是VB程序所在目录的Gallery子目录中，如果不是则文件会找不到。<br/></p> mccad发表于2009-5-22 21:07:00static/image/common/back.gif看了你的代码，还不太好说：1.acadapp本身是AcadApplication对象，就不能用acadapp.Application，而需要直接acadapp.Documents(\"文件名\")。2. 新图形 Dim objNewDoc As AcadDocument 下面的那
<p>恩，先谢谢了！ </p><p>1.这个我也试过。呵呵，不过好像还是不行，不过给我指出了到底该怎么写这句话了。 </p><p>2.恩，这个我后来是修改的时候发现了这个错误，眼力真好！ </p><p>3.这点主要是为了判断在运行程序前是否有ACAD打开了，以免受影响，可能是想过了头，可以不要这句的 </p><p>4.图库就是建立在VB程序所在目录中的Gallery子目录中，所以我用了APP.PATH </p><p>最后真的很感谢<font color="#ff0000">mccad<font color="#000000">和</font><strong><font face="Verdana">lzh741206</font></strong></font>！还是要感谢这个论坛给我学习二次开发提供了很多帮助 </p><p>很多问题先是经过搜索论坛和百度解决了，是在没有解决的，最终都在版主们和大家的热心帮助下基本上都解决了 </p><p>谢谢了！</p> 本帖最后由 作者 于 2009-5-23 20:33:34 编辑 <br /><br /> <p>目前就只缺那个没有实现，还是会提示错误。如果实现了就好。</p><p>全部代码如下：</p><p>'连接AutoCAD<br/>Public Sub AutoCAD_Appliaction()<br/> On Error Resume Next<br/> Dim Thisdrawing As AcadDocument<br/> Set acadapp = GetObject(, "AutoCAD.Application.16")<br/> If Err Then<br/> Err.Clear<br/> Set acadapp = CreateObject("AutoCAD.Application.16")<br/> If Err Then<br/> MainForm.Visible = False<br/> MsgBox Err.Description<br/> MainForm.Visible = True<br/> Exit Sub<br/> End If<br/> Else<br/> If acadapp.Documents.Count >= 1 Then<br/> For i = acadapp.Documents.Count To 1 Step -1<br/> Set Thisdrawing = acadapp.Documents.Item(i - 1)<br/> If Not acadapp.ActiveDocument.Saved Then<br/> If MsgBox("是否要保存以前打开的.dwg文件？", vbYesNo) = vbYes Then<br/> acadapp.ActiveDocument.Save<br/> Else<br/> acadapp.ActiveDocument.Close (False)<br/> End If<br/> End If<br/> Thisdrawing.Close<br/> Next<br/> End If<br/> End If<br/> Set Thisdrawing = Nothing<br/> acadapp.Visible = True<br/> acadapp.WindowState = acMax<br/>End Sub</p><p>'打开图库<br/>Public Sub Open_Gallery(Galleryname As String)<br/>On Error Resume Next<br/>Dim file As String<br/>file = App.Path & "\Gallery\" & Galleryname & ".dwg"<br/> If Dir(file) <> "" Then<br/> acadapp.Documents.Open file<br/> Else<br/> MsgBox ("文件" & Galleryname & "不存在")<br/> End If<br/>End Sub</p><p>'建立选择集并遍历选择集中实体并复制移动实体<br/>Public Sub copy_moveSset(selectname As String, jielength As Double, jienum As Integer, Layername As String)<br/>On Error Resume Next<br/> acadapp.SelectionSets(selectname).Delete<br/> Set ssetobj = acadapp.ActiveDocument.SelectionSets.Add(selectname)<br/>AppActivate acadapp.Caption<br/>'建立选择集，选择图层<br/>Dim fType(0) As Integer<br/>Dim fData(0) As Variant<br/> fType(0) = 8<br/> fData(0) = Layername<br/>Dim FilterType As Variant<br/>Dim FilterData As Variant<br/> FilterType = fType<br/> FilterData = fData<br/>ssetobj.Select acSelectionSetAll, , , fType, fData<br/>Dim entry As AcadEntity<br/>Dim coent As Variant<br/>Dim point1(0 To 2) As Double<br/>Dim point2(0 To 2) As Double<br/> For i = 1 To jienum<br/> point1(0) = 0#<br/> point1(1) = 0#<br/> point1(2) = 0#<br/> point2(0) = point1(0) + (i - 1) * jielength<br/> point2(1) = 0#<br/> point2(2) = 0#<br/> For Each entry In ssetobj<br/> Set coent = entry.Copy<br/> Call coent.Move(point1, point2)<br/> Next<br/> Next i<br/> ssetobj.Delete<br/>End Sub</p><p>'返回包含于选择集中每一项目的变体数,参数:一选择集</p><p>Public Function ssArray(ss As AcadSelectionSet)<br/> Dim retVal() As AcadEntity, k As Long<br/> ReDim retVal(0 To ss.Count - 1)<br/> For k = 0 To ss.Count - 1<br/> Set retVal(k) = ss.Item(k)<br/> Next<br/> ssArray = retVal<br/>End Function</p><p>'建立选择集<br/>Public Function CreateSelectionSet(Optional ByVal SSetName As String) As AcadSelectionSet<br/> On Error Resume Next<br/> '建立选择集<br/> acadapp.ActiveDocument.SelectionSets(SSetName).Delete<br/> Set CreateSelectionSet = acadapp.ActiveDocument.SelectionSets.Add(SSetName)<br/>End Function</p><p>'打开到一张图纸上<br/>Public Sub CopyFromOuterdwg(CurDocname As String, NewDocname As String)<br/> ' 打开第一张图<br/> Dim objCurDoc As AcadDocument<br/> Set objCurDoc = acadapp.Documents(App.Path & "\Gallery\" & CurDocname & ".dwg")<br/>' 打开一个新图形<br/> Dim objNewDoc As AcadDocument<br/> Set objNewDoc = acadapp.Documents(App.Path & "\Gallery\" & NewDocname & ".dwg")<br/> Set objNewDoc = acadapp.ActiveDocument<br/>' 将外部图形的实体复制到当前图形<br/> Set ssetobj = CreateSelectionSet<br/> ssetobj.Select acSelectionSetAll<br/> acadapp.ActiveDocument.CopyObjects ssArray(ssetobj), objCurDoc.ModelSpace<br/> objCurDoc.Regen acAllViewports<br/> ' 关闭打开的图形<br/> objNewDoc.Close (False)<br/>End Sub</p><p></p><p>Private Sub Command7_Click()</p><p> AutoCAD_Appliaction<br/> Open_Gallery "预热带前段"<br/> copy_moveSset "NEW1", 232, Val(copy_move.yc_1.Text), "0"<br/> Open_Gallery "预热带中段"<br/> copy_moveSset "NEW1", 232, Val(copy_move.yc_2.Text), "0"<br/> Open_Gallery "预热带后段"<br/> copy_moveSset "NEW1", 232, Val(copy_move.yc_3.Text), "0"<br/> CopyFromOuter "预热带前段", "预热带中段"<br/> CopyFromOuter "预热带前段", "预热带后段"<br/>End Sub</p> <p>整个程序看过了，因为没有VB，就没有做调试，第一感觉这句有问题：<br/>CopyFromOuter "预热带前段", "预热带后段"<br/>前面已经有调用过一次CopyFromOuter ，此时"预热带后段"已经被关了，第二次调用肯定就会出错。</p><p>你是通过程序打开图库文件，最好的方法是直接把打开的文件用变量保存起来，下次调用时就直接用该变量来调用，而不要再通过文件名来指定文件，这样对于编程来说会有好处。<br/></p>
页:
1
[2]