请教用CopyObjects方法产生的块炸碎后插入点偏移的问题
<P>在我的程序中先将用CopyObjects方法产生的块插入图纸中，再用EXPLODE炸碎块，然后用DELETE方法删除块，结果炸碎后的对象偏移了我块插入点很远的位置，没办法只好用sendcommand办法手工解决（炸碎后插入点不变），求教版主如何解决？现贴程序中部分内容：</P><P>Set blkrefobj = ThisDrawing.ModelSpace.InsertBlock(inspt, "tempblock", smin, smin, smin, 0)<BR> <BR> '以下这段用来调整插入后图块的位置</P>
<P> Dim topt(0 To 2) As Double<BR> topt(0) = inspt(0) + ((d(0) - e(0) * smin) / 2)<BR> topt(1) = inspt(1) + ((d(1) - e(1) * smin) / 2)<BR> topt(2) = 0<BR> <BR> blkrefobj.Move inspt, topt <BR> blkrefobj.Update</P>
<P><BR> <BR> ActiveDocument.Utility.Prompt "接下来请选择插入的图块!炸碎后可进行文字高度调整和旋转角度的工作!"<BR> <BR> ThisDrawing.SendCommand "_explode" + Chr(13) '没办法此处只好手工解决炸碎后插入点偏移的问题<BR> <BR> 'blkrefobj.Explode<BR> <BR> 'blkrefobj.Delete<BR> <BR> Application.Update</P> <P>应该是定义块插入点出了问题</P> 能指出问题出在哪吗？有没有解决办法？ 把程序完整贴上来看看 本帖最后由 作者 于 2006-8-10 16:12:26 编辑 <br /><br /> <P>比较乱还属测试阶段不过基本功能可完成，重点看后面。程序的功能是按矩形框大小调整比例。</P>
<P>Public blnCancelled As Boolean<BR>Public s As Double<BR>Public smin As Double<BR>Public sfit As Double<BR>Public sx As Double<BR>Public sy As Double</P>
<P>Sub adjust_scale()</P>
<P> On Error Resume Next<BR> ThisDrawing.PurgeAll<BR> <BR> Dim ss As AcadSelectionSet<BR> Dim pt(0 To 2) As Double<BR> Dim i As Integer<BR> <BR> If ThisDrawing.SelectionSets.Count <> 0 Then<BR> For i = 0 To ThisDrawing.SelectionSets.Count - 1<BR> ThisDrawing.SelectionSets.Item(i).Delete<BR> Next<BR> End If<BR> <BR> Set ss = ThisDrawing.SelectionSets.Add("ssss")<BR> ActiveDocument.Utility.Prompt "确认你选择的不包括图块,否则程序有可能出错!您最好退出此命令炸碎图块后重新操作!"<BR> ss.SelectOnScreen<BR> <BR> If ss.Count <> 0 Then<BR> ReDim retval(0 To ss.Count - 1) As AcadEntity<BR> <BR> For i = 0 To ss.Count - 1<BR> Set retval(i) = ss.Item(i)<BR> Next<BR> <BR> Dim entObj As AcadEntity<BR> Dim minext As Variant, maxext As Variant<BR> Dim a(0 To 2), b(0 To 2) As Double 'a()为右上脚坐标,b()为左下脚坐标<BR> <BR> Set entObj = ss.Item(0)<BR> entObj.GetBoundingBox minext, maxext<BR> <BR> a(0) = maxext(0)<BR> a(1) = maxext(1)<BR> a(2) = maxext(2)<BR> <BR> b(0) = minext(0)<BR> b(1) = minext(1)<BR> b(2) = minext(2)<BR> <BR> For i = 1 To ss.Count - 1<BR> <BR> Set entObj = ss.Item(i)<BR> entObj.GetBoundingBox minext, maxext<BR> <BR> If a(0) < maxext(0) Then<BR> a(0) = maxext(0)<BR> End If<BR> <BR> If a(1) < maxext(1) Then<BR> a(1) = maxext(1)<BR> End If<BR> <BR> If b(0) > minext(0) Then<BR> b(0) = minext(0)<BR> End If<BR> <BR> If b(1) > minext(1) Then<BR> b(1) = minext(1)<BR> End If<BR> <BR> Next<BR> <BR> pt(0) = b(0)<BR> pt(1) = b(1)<BR> pt(2) = b(2)<BR> <BR> Dim bk As AcadBlock<BR> Set bk = ThisDrawing.Blocks.Add(pt, "tempblock")<BR> <BR> ThisDrawing.CopyObjects retval, bk<BR> Erase retval<BR> <BR> Dim c1 As Variant<BR> Dim c2 As Variant<BR> Dim cssize As Integer<BR> <BR> cssize = ThisDrawing.Application.Preferences.Display.cursorsize<BR> ThisDrawing.Application.Preferences.Display.cursorsize = 100<BR> <BR>c1get:<BR> c1 = ThisDrawing.Utility.GetPoint(, "选择边界点1:")<BR> If c1(0) = nil Then GoTo c1get<BR> <BR>c2get:<BR> 'On Error Resume Next<BR> c2 = ThisDrawing.Utility.GetCorner(c1, "选择边界点2:") <BR> If c2(0) = nil Then GoTo c1get<BR> <BR> ThisDrawing.Application.Preferences.Display.cursorsize = cssize<BR> <BR> Dim d(0 To 1) As Double<BR> d(0) = VBA.Abs(c1(0) - c2(0)) '选取范围水平距离<BR> d(1) = VBA.Abs(c1(1) - c2(1)) '选取范围垂直距离<BR> <BR> Dim e(0 To 1) As Double<BR> e(0) = VBA.Abs(b(0) - a(0)) '选取集合水平距离<BR> e(1) = VBA.Abs(b(1) - a(1)) '选取集合垂直距离<BR> <BR> Dim inspt(0 To 2) As Double<BR> Dim blkrefobj As AcadBlockReference<BR> <BR> If c2(0) < c1(0) Then<BR> c1(0) = c2(0)<BR> End If<BR> <BR> If c2(1) < c1(1) Then<BR> c1(1) = c2(1)<BR> End If<BR> <BR> inspt(0) = c1(0): inspt(1) = c1(1): inspt(2) = c1(2)<BR> <BR> sx = d(0) / e(0)<BR> sy = d(1) / e(1)<BR> <BR> smin = sy<BR> If sy > sx Then<BR> smin = sx<BR> End If<BR> <BR> sfit = CInt(100 * smin) / 100<BR> sx = smin<BR> sy = smin<BR> <BR> blnCancelled = False<BR> <BR> If blnCancelled = False Then<BR> <BR> Dim sc As Double<BR> sc = ThisDrawing.Utility.GetReal("请输入缩放比例" & "(回车使用默认值" & (CInt(100 * smin) / 100) & "):")<BR> If sc <> nil Then smin = VBA.Abs(sc)<BR> <BR> ss.Erase<BR> <BR> Set blkrefobj = ThisDrawing.ModelSpace.InsertBlock(inspt, "tempblock", smin, smin, smin, 0)<BR> <BR> Dim topt(0 To 2) As Double<BR> topt(0) = inspt(0) + ((d(0) - e(0) * smin) / 2)<BR> topt(1) = inspt(1) + ((d(1) - e(1) * smin) / 2)<BR> topt(2) = 0<BR> <BR> blkrefobj.Move inspt, topt<BR> <BR> blkrefobj.Update<BR> <BR> ActiveDocument.Utility.Prompt "接下来请选择插入的图块!炸碎后可进行文字高度调整和旋转角度的工作!"<BR> <BR> ThisDrawing.SendCommand "_explode" + Chr(13)<BR> <BR> 'blkrefobj.Explode<BR> <BR> 'blkrefobj.Delete<BR> <BR> Application.Update<BR> <BR> End If<BR> </P>
<P> End If<BR> <BR>errhandle:<BR> <BR> If ThisDrawing.SelectionSets.Count <> 0 Then<BR> For i = 0 To ThisDrawing.SelectionSets.Count - 1<BR> ThisDrawing.SelectionSets.Item(i).Delete<BR> Next<BR> End If<BR> <BR> ThisDrawing.PurgeAll <BR> </P>
<P>End Sub</P> <P>侠之大者能帮忙解答吗？</P>
<P> </P> 是分解的问题,当以不等的X,Y,Z比例系数插入时,分解后的图象与原图形不同,如果都是1:1则不会出现此问题 <P>用以下语句代替ThisDrawing.SendCommand "_explode" + Chr(13)</P>
<P>Dim Handle1<BR>Handle1 = blkrefobj.Handle<BR>ThisDrawing.SendCommand "_explode" & vbCr & "(handent " & Chr(34) & Handle1 & Chr(34) & ")" & vbCr & vbCr</P>
<P>就不用手动干预了</P> <P>谢谢楼上的答复，程序中插入比例X/Y/Z轴都是相等的（均为smin），我也曾注意到不等时炸碎出现的问题。楼上提供的方法帮我解决了大问题，再次表示谢意，希望今后能多得到您的指教。</P>
页:
[1]