急救，VBA中,如何把一个闭合图形,向四周缩放

wgwgoto

急救，VBA中,如何把一个闭合图形,向四周缩放，比如说，圆中沿心，矩形沿中心，不规则的闭合图形也是沿中心缩放。

谢谢！

今晚打老虎

用OFFSET试试～～～

mccad

把对象变成面域后，找质心，然后删除面域，然后再把对象从质心来缩放。

wjfling

能给一段代码吗？

mccad

2. Sub ScaleEntFromCentro()
   
3.     On Error Resume Next
   
4.     Dim Ent As AcadEntity
   
5.     Dim Pnt As Variant
   
6.     ThisDrawing.Utility.GetEntity Ent, Pnt, "选择对象："
   
7.     Dim Ents(0) As AcadEntity
   
8.     Set Ents(0) = Ent
   
9.     Dim Regs As Variant
   
10.     Dim Reg As AcadRegion
    
11.     Regs = ThisDrawing.ModelSpace.AddRegion(Ents)
    
12.     If Err Then
    
13.         Err.Clear
    
14.         ThisDrawing.Utility.Prompt "选中的对象不能找到合适的中心，程序不能继续进行。"
    
15.         Exit Sub
    
16.     End If
    
17.     If IsArray(Regs) Then
    
18.         Set Reg = Regs(0)
    
19.         Dim Org As Variant
    
20.         Org = Reg.Centroid
    
21.         Reg.Delete
    
22.         ThisDrawing.SendCommand "scale" & vbCr & axEnt2lspEnt(Ent) & vbCr & vbCr & axPoint2lspPoint(Org) & vbCr
    
23.     Else
    
24.         ThisDrawing.Utility.Prompt "没有选中闭合的对象，程序不能继续进行。"
    
25.     End If
    
26. End Sub
    
27. 
    
28. Public Function axEnt2lspEnt(entObj As AcadEntity) As String
    
29.     Dim entHandle As String
    
30.     entHandle = entObj.Handle
    
31.     axEnt2lspEnt = "(handent " & Chr(34) & entHandle & Chr(34) & ")"
    
32. End Function
    
33. 
    
34. Public Function axPoint2lspPoint(Pnt As Variant) As String
    
35.     axPoint2lspPoint = Pnt(0) & "," & Pnt(1)
    
36. End Function
    

Sub ScaleEntFromCentro()<br />     On Error Resume Next<br />     Dim Ent As AcadEntity<br />     Dim Pnt As Variant<br />     ThisDrawing.Utility.GetEntity Ent, Pnt, "选择对象："<br />     Dim Ents(0) As AcadEntity<br />     Set Ents(0) = Ent<br />     Dim Regs As Variant<br />     Dim Reg As AcadRegion<br />     Regs = ThisDrawing.ModelSpace.AddRegion(Ents)<br />     If Err Then<br />         Err.Clear<br />         ThisDrawing.Utility.Prompt "选中的对象不能找到合适的中心，程序不能继续进行。"<br />         Exit Sub<br />     End If<br />     If IsArray(Regs) Then<br />         Set Reg = Regs(0)<br />         Dim Org As Variant<br />         Org = Reg.Centroid<br />         Reg.Delete<br />         ThisDrawing.SendCommand "scale" & vbCr & axEnt2lspEnt(Ent) & vbCr & vbCr & axPoint2lspPoint(Org) & vbCr<br />     Else<br />         ThisDrawing.Utility.Prompt "没有选中闭合的对象，程序不能继续进行。"<br />     End If<br /> End Sub<br /> <br /> Public Function axEnt2lspEnt(entObj As AcadEntity) As String<br />     Dim entHandle As String<br />     entHandle = entObj.Handle<br />     axEnt2lspEnt = "(handent " & Chr(34) & entHandle & Chr(34) & ")"<br /> End Function<br /> <br /> Public Function axPoint2lspPoint(Pnt As Variant) As String<br />     axPoint2lspPoint = Pnt(0) & "," & Pnt(1)<br /> End Function<br />