请帮忙关于文件之间传送图形的问题
各位高手：在下碰到一个问题，目的：由于不同项目的图纸，大都相似，标题栏又不同内容，比如新项目标题栏里要求写“张家港项目”，老项目图纸是广州的，为了少做重复工作，我的想法是改好一张，（标题栏是块），其余的图纸编个VB的程序自动修改
1，我首先想到的是用OBJECTDBX技术，但是他又不能脱离AUTOCAD程序，只好放弃
2，现在想利用打开两个cad，复制，再粘贴，程序不知该如何写了
以下是我的部分程序，请指教错在哪里（注意，我使用VB编的）
提前谢了
'===================================<BR> '===================================<BR> '========如果有属性块替换任务=======<BR> '===================================<BR> '===================================<BR> '第一步，将定义的数组更新<BR> <BR> '判断但前图形是否在模型空间中<BR> If dwgfile.ActiveSpace = acModelSpace Then<BR> '查早目标块<BR> For Each obj In dwgfile.ModelSpace<BR> '显示进程<BR> cadmessage.Label7.Caption = "正在进行目标块替换： 查找目标块块 " & oldblk & " 当前 " & obj.ObjectName<BR> '首先判断块类型是否为块属性<BR> If obj.ObjectName = "AcDbBlockReference" Then<BR> '再判断是否为要查找的目标块<BR> If obj.Name = oldblk Then<BR> '显示进程<BR> cadmessage.Label7.Caption = "正在进行目标块替换： 已找到 " & oldblk & " 当前正属性提取中。。。"<BR> '获取块属性集<BR> objatts = obj.GetAttributes<BR> For i = 1 To replacetime - 1<BR> If reblk(2, i) <> "常量" Then<BR> For m = LBound(objatts) To UBound(objatts)<BR> If objatts(m).TagString = reblk(2, i) Then<BR> reblk(3, i) = objatts(m).TextString<BR> Exit For<BR> End If<BR> Next m<BR> End If<BR> <BR> Next i<BR> cadmessage.Label7.Caption = "正在进行目标块替换： 获取目标块 " & oldblk & " 当前的宽度值及右下角点"<BR> '第二步，获取目标块的宽度值然后删除目标块<BR> obj.GetBoundingBox minExt, maxExt<BR> oldleftpoint(0) = minExt(0)<BR> oldleftpoint(1) = minExt(1)<BR> oldleftpoint(2) = minExt(2)<BR> <BR> oldrightpoint(0) = maxExt(0)<BR> oldrightpoint(1) = minExt(1)<BR> oldrightpoint(2) = minExt(2)<BR> oldblkwidth = maxExt(0) - minExt(0)<BR> cadmessage.Label7.Caption = "正在进行目标块替换： 删除目标块 " & oldblk<BR> 'obj.Delete<BR> 'Update<BR> <BR> Exit For<BR> End If<BR> <BR> End If<BR> Next obj<BR> End If<BR> <BR> <BR> '第三步，插入新图块<BR> cadmessage.Label7.Caption = "正在进行目标块替换： 插入新图块 " & newblk<BR> 'set_objdbx
<BR> dwg1.Documents.Open newblkfile<BR> Set newblkobj(0) = dwg1.ActiveDocument.Blocks(newblk)<BR> <FONT color=#e6421a><b>dwg1.ActiveDocument.CopyObjects newblkobj, dwgfile.ModelSpace</b></FONT>
<EM><FONT color=#0909f7>就是在这出错的！</FONT></EM><BR> If dwgfile.ActiveSpace = acModelSpace Then<BR> dwgfile.ModelSpace.InsertBlock oldrightpoint, newblk, 1, 1, 1, 0<BR> dwgfile.Regen acActiveViewport<BR> dwg.Update<BR> <BR> End If<BR> If dwgfile.ActiveSpace = acPaperSpace Then<BR> dwgfile.PaperSpace.InsertBlock oldrightpoint, newblk, 1, 1, 1, 0<BR> dwgfile.Regen acActiveViewport<BR> dwg.Update<BR> End If<BR> '第四步，新图块属性更新<BR> If dwgfile.ActiveSpace = acModelSpace Then<BR> i = dwgfile.ModelSpace.Count<BR> '查早目标块<BR> For Each obj In dwgfile.ModelSpace<BR> '显示进程<BR> cadmessage.Label7.Caption = "正在进行目标块替换： 查找新的属性块 " & newblk & " 当前 " & obj.ObjectName<BR> '首先判断块类型是否为块属性<BR> If obj.ObjectName = "AcDbBlockReference" Then<BR> '再判断是否为要查找的目标块<BR> If obj.Name = newblk Then<BR> '显示进程<BR> cadmessage.Label7.Caption = "正在进行目标块替换： 已找到 " & newblk & " 当前正属性更新中。。。"<BR> '获取块属性集<BR> objatts = obj.GetAttributes<BR> <BR> For i = 1 To replacetime - 1<BR> <BR> For m = LBound(objatts) To UBound(objatts)<BR> If objatts(m).TagString = reblk(1, i) Then<BR> objatts(m).TextString = reblk(3, i)<BR> Exit For<BR> End If<BR> Next m<BR> <BR> <BR> Next i<BR> '''''''''''''''''''''''''''<BR> '第五步，新图块宽度改为与旧块一致<BR> obj.GetBoundingBox minExt, maxExt<BR> newleftpoint(0) = minExt(0)<BR> newleftpoint(1) = minExt(1)<BR> newleftpoint(2) = minExt(2)<BR> newrightpoint(0) = maxExt(0)<BR> newrightpoint(1) = minExt(1)<BR> newrightpoint(2) = minExt(2)<BR> newblkwidth = maxExt(0) - minExt(0)<BR> obj.ScaleEntity newrightpoint, oldblkwidth / newblkwidth<BR> '第五步，移动新块到旧块的原位置<BR> obj.Move newrightpoint, oldrightpoint<BR> dwg.Update<BR> dwg.ZoomAll<BR> <BR> Exit For<BR> <BR> End If<BR> <BR> End If<BR> <BR> Next obj<BR> End If<BR> <BR> '判断结束 OBJECTDBX技术摆脱不了AutoCad
打开两个cad，复制，再粘贴－－ 一样摆脱不了AutoCad
用OBJECTDBX要简单些吧 本帖最后由 作者 于 2005-3-23 17:31:54 编辑 <br /><br /> 上面那个问题我已经解决了
如下：
'第三步，插入新图块<BR> cadmessage.Label7.Caption = "正在进行目标块替换： 插入新图块 " & newblk<BR> Set olddrawing = dwg.Application.ActiveDocument<BR> Set newdrawing = dwg.Application.Documents.Open(newblkfile)<BR> newdrawing.Activate<BR> For Each obj In dwg.ActiveDocument.ModelSpace<BR> If obj.ObjectName = "AcDbBlockReference" Then<BR> '再判断是否为要查找的目标块<BR> If obj.Name = newblk Then<BR> Set newblkobj(0) = obj<BR> dwg.ActiveDocument.CopyObjects newblkobj, olddrawing.ModelSpace<BR> <BR> End If<BR> End If<BR> Next<BR> olddrawing.Activate<BR> dwgfile.Regen acAllViewports<BR> dwg.Update<BR> 现在又遇到新的问题，在vb状态下，无法实现物体移动即object.move不能用，而且object.scaleentity也不能用，总提示无效属性
源码如下：
ScaleFactor = oldblkwidth / newblkwidth<BR> 'Set obj1 = obj<BR> 'obj.ScaleEntity newrightpoint, ScaleFactor<BR> obj.XScaleFactor = ScaleFactor<BR> obj.YScaleFactor = ScaleFactor<BR> obj.Update<BR> 'dwg.ActiveDocument.SendCommand "_move" & vbCr & obj & vbCr & newrightpoint & vbCr & oldrightpoint & vbCr<BR> 'obj.BasePoint = newrightpoint<BR> 'obj.Delete<BR> <BR> 'dwgfile.ModelSpace.InsertBlock oldrightpoint, newblk, ScaleFactor, ScaleFactor, ScaleFactor<BR> <BR> 'dwg.ActiveDocument.SendCommand "_scale" & vbCr & obj & vbCr & ScaleFactor & vbCr<BR> '第五步，移动新块到旧块的原位置<BR> dwg.Visible = True<BR> <FONT color=#f73809> obj.Move newrightpoint, oldrightpoint</FONT><BR> <b>运行到此出错！！！！！！！</b><BR> dwg.Update<BR> dwg.Visible = False<BR> 'dwg.ZoomAll<BR>
再次请斑竹帮忙呀？！！
谢谢
页:
[1]