请帮忙关于文件之间传送图形的问题

CLARKLEE

各位高手：在下碰到一个问题， 目的：由于不同项目的图纸，大都相似，标题栏又不同内容，比如新项目标题栏里要求写“张家港项目”，老项目图纸是广州的，为了少做重复工作，我的想法是改好一张，（标题栏是块），其余的图纸编个VB的程序自动修改 1，我首先想到的是用OBJECTDBX技术，但是他又不能脱离AutoCAD程序，只好放弃 2，现在想利用打开两个cad，复制，再粘贴，程序不知该如何写了 以下是我的部分程序，请指教错在哪里（注意，我使用VB编的） 提前谢了 '===================================
'===================================
'========如果有属性块替换任务=======
'===================================
'===================================
'第一步，将定义的数组更新

'判断但前图形是否在模型空间中
If dwgfile.ActiveSpace = acModelSpace Then
'查早目标块
For Each obj In dwgfile.ModelSpace
'显示进程
cadmessage.Label7.Caption = "正在进行目标块替换： 查找目标块块 " & oldblk & " 当前 " & obj.ObjectName
'首先判断块类型是否为块属性
If obj.ObjectName = "AcDbBlockReference" Then
'再判断是否为要查找的目标块
If obj.Name = oldblk Then
'显示进程
cadmessage.Label7.Caption = "正在进行目标块替换： 已找到 " & oldblk & " 当前正属性提取中。。。"
'获取块属性集
objatts = obj.GetAttributes
For i = 1 To replacetime - 1
If reblk(2, i) <> "常量" Then
For m = LBound(objatts) To UBound(objatts)
If objatts(m).TagString = reblk(2, i) Then
reblk(3, i) = objatts(m).TextString
Exit For
End If
Next m
End If

Next i
cadmessage.Label7.Caption = "正在进行目标块替换： 获取目标块 " & oldblk & " 当前的宽度值及右下角点"
'第二步，获取目标块的宽度值然后删除目标块
obj.GetBoundingBox minExt, maxExt
oldleftpoint(0) = minExt(0)
oldleftpoint(1) = minExt(1)
oldleftpoint(2) = minExt(2)

oldrightpoint(0) = maxExt(0)
oldrightpoint(1) = minExt(1)
oldrightpoint(2) = minExt(2)
oldblkwidth = maxExt(0) - minExt(0)
cadmessage.Label7.Caption = "正在进行目标块替换： 删除目标块 " & oldblk
'obj.Delete
'Update

Exit For
End If

End If
Next obj
End If


'第三步，插入新图块
cadmessage.Label7.Caption = "正在进行目标块替换： 插入新图块 " & newblk
'set_objdbx
dwg1.Documents.Open newblkfile
Set newblkobj(0) = dwg1.ActiveDocument.Blocks(newblk)
dwg1.ActiveDocument.CopyObjects newblkobj, dwgfile.ModelSpace 就是在这出错的！
If dwgfile.ActiveSpace = acModelSpace Then
dwgfile.ModelSpace.InsertBlock oldrightpoint, newblk, 1, 1, 1, 0
dwgfile.Regen acActiveViewport
dwg.Update

End If
If dwgfile.ActiveSpace = acPaperSpace Then
dwgfile.PaperSpace.InsertBlock oldrightpoint, newblk, 1, 1, 1, 0
dwgfile.Regen acActiveViewport
dwg.Update
End If
'第四步，新图块属性更新
If dwgfile.ActiveSpace = acModelSpace Then
i = dwgfile.ModelSpace.Count
'查早目标块
For Each obj In dwgfile.ModelSpace
'显示进程
cadmessage.Label7.Caption = "正在进行目标块替换： 查找新的属性块 " & newblk & " 当前 " & obj.ObjectName
'首先判断块类型是否为块属性
If obj.ObjectName = "AcDbBlockReference" Then
'再判断是否为要查找的目标块
If obj.Name = newblk Then
'显示进程
cadmessage.Label7.Caption = "正在进行目标块替换： 已找到 " & newblk & " 当前正属性更新中。。。"
'获取块属性集
objatts = obj.GetAttributes

For i = 1 To replacetime - 1

For m = LBound(objatts) To UBound(objatts)
If objatts(m).TagString = reblk(1, i) Then
objatts(m).TextString = reblk(3, i)
Exit For
End If
Next m


Next i
'''''''''''''''''''''''''''
'第五步，新图块宽度改为与旧块一致
obj.GetBoundingBox minExt, maxExt
newleftpoint(0) = minExt(0)
newleftpoint(1) = minExt(1)
newleftpoint(2) = minExt(2)
newrightpoint(0) = maxExt(0)
newrightpoint(1) = minExt(1)
newrightpoint(2) = minExt(2)
newblkwidth = maxExt(0) - minExt(0)
obj.ScaleEntity newrightpoint, oldblkwidth / newblkwidth
'第五步，移动新块到旧块的原位置
obj.Move newrightpoint, oldrightpoint
dwg.Update
dwg.ZoomAll

Exit For

End If

End If

Next obj
End If

'判断结束

雪山飞狐_lzh

OBJECTDBX技术摆脱不了AutoCad


打开两个cad，复制，再粘贴－－ 一样摆脱不了AutoCad


用OBJECTDBX要简单些吧

CLARKLEE

上面那个问题我已经解决了 如下： '第三步，插入新图块
cadmessage.Label7.Caption = "正在进行目标块替换： 插入新图块 " & newblk
Set olddrawing = dwg.Application.ActiveDocument
Set newdrawing = dwg.Application.Documents.Open(newblkfile)
newdrawing.Activate
For Each obj In dwg.ActiveDocument.ModelSpace
If obj.ObjectName = "AcDbBlockReference" Then
'再判断是否为要查找的目标块
If obj.Name = newblk Then
Set newblkobj(0) = obj
dwg.ActiveDocument.CopyObjects newblkobj, olddrawing.ModelSpace

End If
End If
Next
olddrawing.Activate
dwgfile.Regen acAllViewports
dwg.Update
现在又遇到新的问题，在vb状态下，无法实现物体移动即object.move不能用，而且object.scaleentity也不能用，总提示无效属性 源码如下： ScaleFactor = oldblkwidth / newblkwidth
'Set obj1 = obj
'obj.ScaleEntity newrightpoint, ScaleFactor
obj.XScaleFactor = ScaleFactor
obj.YScaleFactor = ScaleFactor
obj.Update
'dwg.ActiveDocument.SendCommand "_move" & vbCr & obj & vbCr & newrightpoint & vbCr & oldrightpoint & vbCr
'obj.BasePoint = newrightpoint
'obj.Delete

'dwgfile.ModelSpace.InsertBlock oldrightpoint, newblk, ScaleFactor, ScaleFactor, ScaleFactor

'dwg.ActiveDocument.SendCommand "_scale" & vbCr & obj & vbCr & ScaleFactor & vbCr
'第五步，移动新块到旧块的原位置
dwg.Visible = True
obj.Move newrightpoint, oldrightpoint
运行到此出错！！！！！！！
dwg.Update
dwg.Visible = False
'dwg.ZoomAll
再次请斑竹帮忙呀？！！ 谢谢