vba 局部放大程序 快速绘制详图
说实在的 我还不会。不过我很想实现它。他对绘图很重要。网络上面有个lisp的,还不错,不过他还要注册。
下面的是我昨天刚写的,目前只能处理直线、圆弧。vba处理起来有点难度。
Sub JBFD2()
On Error Resume Next
'通过三点确定一个圆型区域
Dim P1 As Variant
Dim P2 As Variant
Dim P3 As Variant
ThisDrawing.Utility.InitializeUserInput 1, ""
P1 = ThisDrawing.Utility.GetPoint(, "边界上的第一点:")
ThisDrawing.Utility.InitializeUserInput 1, ""
P2 = ThisDrawing.Utility.GetPoint(, "边界上的第二点:")
ThisDrawing.Utility.InitializeUserInput 1, ""
P3 = ThisDrawing.Utility.GetPoint(, "边界上的第三点:")
Dim C As AcadCircle
Set C = AddCircle3P(P1, P2, P3)
'圆所在的矩形区域
Dim PMin As Variant
Dim Pmax As Variant
C.GetBoundingBox PMin, Pmax
'绘制圆所在的矩形区域
'DrawBoundingBox C
'文档最后绘制的对象,也就是该圆为红色
ThisDrawing.ModelSpace.item(ThisDrawing.ModelSpace.Count - 1).color = acRed
'创建选择集,于改矩形区域相交的对象均选中。
Dim ssetObj As AcadSelectionSet
Set ssetObj = ThisDrawing.SelectionSets.Add("SSET")
Dim mode As Integer
'mode = acSelectionSetWindow '位于区域窗口内部的对象被选中
mode = acSelectionSetCrossing '于区域窗口有交点的对象均被选中。
ssetObj.Select mode, Pmax, PMin
Dim Obj() As Object
'将选择集中对象传递给Obj对象数组
ReDim Obj(0 To ssetObj.Count - 1) As Object
For i = 0 To ssetObj.Count - 1
Set Obj(i) = ssetObj.item(i)
Next i
'创建一个块体,将圆和该对象均添加进去。
'编辑该块体中的对象
'找到对象和圆的交点
' 没有交点的是完全在圆内部的对象。不可能没有交点的。
' 通过修改直线的起点和终点达到修剪的目的
Dim B As AcadBlock
Set B = ThisDrawing.Blocks.Add(C.center, "*B")
' 将数组中的实体复制到块定义中
ThisDrawing.CopyObjects Obj, B
'首先将圆添加到块中
Dim C1 As AcadCircle
Set C1 = B.AddCircle(C.center, C.radius)
Dim E As AcadEntity
Dim L As AcadLine
Dim C2 As AcadCircle
Dim PL As AcadLWPolyline
Dim Arc As AcadArc
Dim Pt As Variant
Dim DistS As Double
Dim DistE As Double
Dim Dist As Double
Dim StAng As Double
Dim EnAng As Double
Dim Ang
Dim ZuoBiao As Variant '原坐标数组
Dim ZuoBiao1 As Variant '新坐标数组
For Each E In B
'MsgBox E.ObjectName
ThisDrawing.Utility.Prompt E.ObjectName & vbLf
Select Case E.ObjectName
Case "AcDbLine"
Set L = E
Pt = L.IntersectWith(C1, acExtendNone)
'端点到圆心的距离
DistS = P2PDistance(C1.center, L.StartPoint)
DistE = P2PDistance(C1.center, L.EndPoint)
'MsgBox UBound(Pt)
If UBound(Pt) = 2 Then '没有交点为-1,有交点为2,有两个交点为5,直线和圆也只能有两个交点
'B.AddPoint Point3D(Pt(0), Pt(1), Pt(2))
'到圆心距离大于圆的半径,则说明点在圆外
If DistS > C1.radius Then L.StartPoint = Pt '起始点在圆外
If DistE > C1.radius Then L.EndPoint = Pt '终止点在圆外
ElseIf UBound(Pt) = 5 Then
L.StartPoint = Point3D(Pt(0), Pt(1), Pt(2))
L.EndPoint = Point3D(Pt(3), Pt(4), Pt(5))
Else '没有交点
If DistS > C.radius Then '在没有交点的情况之下,只要判断其中一点是否在圆内,就知道直线是否在圆内,不妨就判断起点。
L.Delete
End If
End If
Case "AcDbPolyline"
'建立坐标数组,坐标数组顺序保持不变,将交点的坐标插入进去,建立新的数组。
Set PL = E
ZuoBiao = PL.Coordinates
'MsgBox UBound(ZuoBiao)
For i = 0 To (UBound(ZuoBiao) + 1) / 3
Dist = P2PDistance(Point3D(ZuoBiao(i), ZuoBiao(i + 1), ZuoBiao(i + 2)), C1.center)
If Dist <= C1.radius Then
ZuoBiao1(i) = ZuoBiao(i): ZuoBiao1(i + 1) = ZuoBiao(i + 1): ZuoBiao1(i + 2) = ZuoBiao(i + 2):
Else
B.AddPolyline ZuoBiao1
End If
Next
PL.Delete
Case "AcDbCircle"
Set C2 = E
Pt = C2.IntersectWith(C1, acExtendNone)
Dist = P2PDistance(C1.center, C2.center)
'MsgBox UBound(Pt)
'圆和圆相交有五种情况,一是相交与两点,而是相切与一点,三是重合,四是在圆外,五是在圆内
'B.AddPoint Point3D(Pt(0), Pt(1), Pt(2))
If UBound(Pt) = -1 Then '没有交点的情况
'圆心距离大于半径之和则在圆外则,删除。
If Dist > C1.radius + C2.radius Then C2.Delete
ElseIf UBound(Pt) = 5 Then
'MsgBox ""
'计算起点角度和终点角度
StAng = ThisDrawing.Utility.AngleFromXAxis(C2.center, Point3D(Pt(0), Pt(1), Pt(2)))
EnAng = ThisDrawing.Utility.AngleFromXAxis(C2.center, Point3D(Pt(3), Pt(4), Pt(5)))
Set Arc = B.AddArc(C2.center, C2.radius, EnAng, StAng) '不知道cad的交点数组是怎么算出来的?注意这儿的角度
C2.Delete
ElseIf UBound(Pt) = 2 Then '相切的时候还分内切和外切
If Dist = C1.radius + C2.radius Then C2.Delete '在外切的情况下删除
End If
Case "AcDbArc"
Set Arc = E
Pt = Arc.IntersectWith(C1, acExtendNone)
'MsgBox UBound(Pt)
'圆弧和圆相交有六种情况,一是相交与两点,而是相切与一点,相交与一点,在圆内,在圆外,重合
B.AddPoint Point3D(Pt(0), Pt(1), Pt(2))
If UBound(Pt) = -1 Then '没有交点的情况
'因为是矩形窗口的选择,可能出现圆包含与圆弧所在的圆内,不能通过圆心到圆心的距离来判断。
Dist = P2PDistance(C1.center, Arc.StartPoint)
If Dist > C1.radius Then Arc.Delete
ElseIf UBound(Pt) = 5 Then '这个情况应该和圆的情况一样?
'计算起点角度和终点角度
StAng = ThisDrawing.Utility.AngleFromXAxis(Arc.center, Point3D(Pt(0), Pt(1), Pt(2)))
EnAng = ThisDrawing.Utility.AngleFromXAxis(Arc.center, Point3D(Pt(3), Pt(4), Pt(5)))
B.AddArc Arc.center, Arc.radius, EnAng, StAng '不知道cad的交点数组是怎么算出来的?注意这儿的角度
Arc.Delete
ElseIf UBound(Pt) = 2 Then
Ang = ThisDrawing.Utility.AngleFromXAxis(Arc.center, Point3D(Pt(0), Pt(1), Pt(2)))
'MsgBox StAng
'MsgBox Arc.StartAngle
DistS = P2PDistance(C1.center, Arc.StartPoint)
DistE = P2PDistance(C1.center, Arc.endtPoint)
If DistS > C1.radius Then '当起点在外面的时候,从交点到终点绘制圆弧
MsgBox ""
B.AddArc Arc.center, Arc.radius, Ang, Arc.EndAngle
Arc.Delete
End If
If DistE > C1.radius Then '当终点在外面的时候,从起点向交点绘制圆弧
B.fAddArc Arc.center, Arc.radius, Arc.StartAngle, Ang
Arc.Delete
End If
'还有一点就是交点就是起点或终点但是他在圆上,令外一点在圆内,留着此圆弧。
End If
End Select
E.color = acRed
Next
'指定块插入点
Dim P As Variant
ThisDrawing.Utility.InitializeUserInput 1, ""
P = ThisDrawing.Utility.GetPoint(, "详图插入点:")
Dim SC As Integer
SC = Int(ThisDrawing.Utility.GetDistance(, "放大系数( 2 ):"))
'不论是按下esc键还是按下enter键都取默认值
If Err Then
SC = 2
Err.Clear
End If
ThisDrawing.ModelSpace.InsertBlock P, B.Name, SC, SC, SC, 0
ThisDrawing.SelectionSets.item("SSET").Delete
End Sub
On Error Resume Next
'通过三点确定一个圆型区域
Dim P1 As Variant
Dim P2 As Variant
Dim P3 As Variant
ThisDrawing.Utility.InitializeUserInput 1, ""
P1 = ThisDrawing.Utility.GetPoint(, "边界上的第一点:")
ThisDrawing.Utility.InitializeUserInput 1, ""
P2 = ThisDrawing.Utility.GetPoint(, "边界上的第二点:")
ThisDrawing.Utility.InitializeUserInput 1, ""
P3 = ThisDrawing.Utility.GetPoint(, "边界上的第三点:")
Dim C As AcadCircle
Set C = AddCircle3P(P1, P2, P3)
'圆所在的矩形区域
Dim PMin As Variant
Dim Pmax As Variant
C.GetBoundingBox PMin, Pmax
'绘制圆所在的矩形区域
'DrawBoundingBox C
'文档最后绘制的对象,也就是该圆为红色
ThisDrawing.ModelSpace.item(ThisDrawing.ModelSpace.Count - 1).color = acRed
'创建选择集,于改矩形区域相交的对象均选中。
Dim ssetObj As AcadSelectionSet
Set ssetObj = ThisDrawing.SelectionSets.Add("SSET")
Dim mode As Integer
'mode = acSelectionSetWindow '位于区域窗口内部的对象被选中
mode = acSelectionSetCrossing '于区域窗口有交点的对象均被选中。
ssetObj.Select mode, Pmax, PMin
Dim Obj() As Object
'将选择集中对象传递给Obj对象数组
ReDim Obj(0 To ssetObj.Count - 1) As Object
For i = 0 To ssetObj.Count - 1
Set Obj(i) = ssetObj.item(i)
Next i
'创建一个块体,将圆和该对象均添加进去。
'编辑该块体中的对象
'找到对象和圆的交点
' 没有交点的是完全在圆内部的对象。不可能没有交点的。
' 通过修改直线的起点和终点达到修剪的目的
Dim B As AcadBlock
Set B = ThisDrawing.Blocks.Add(C.center, "*B")
' 将数组中的实体复制到块定义中
ThisDrawing.CopyObjects Obj, B
'首先将圆添加到块中
Dim C1 As AcadCircle
Set C1 = B.AddCircle(C.center, C.radius)
Dim E As AcadEntity
Dim L As AcadLine
Dim C2 As AcadCircle
Dim PL As AcadLWPolyline
Dim Arc As AcadArc
Dim Pt As Variant
Dim DistS As Double
Dim DistE As Double
Dim Dist As Double
Dim StAng As Double
Dim EnAng As Double
Dim Ang
Dim ZuoBiao As Variant '原坐标数组
Dim ZuoBiao1 As Variant '新坐标数组
For Each E In B
'MsgBox E.ObjectName
ThisDrawing.Utility.Prompt E.ObjectName & vbLf
Select Case E.ObjectName
Case "AcDbLine"
Set L = E
Pt = L.IntersectWith(C1, acExtendNone)
'端点到圆心的距离
DistS = P2PDistance(C1.center, L.StartPoint)
DistE = P2PDistance(C1.center, L.EndPoint)
'MsgBox UBound(Pt)
If UBound(Pt) = 2 Then '没有交点为-1,有交点为2,有两个交点为5,直线和圆也只能有两个交点
'B.AddPoint Point3D(Pt(0), Pt(1), Pt(2))
'到圆心距离大于圆的半径,则说明点在圆外
If DistS > C1.radius Then L.StartPoint = Pt '起始点在圆外
If DistE > C1.radius Then L.EndPoint = Pt '终止点在圆外
ElseIf UBound(Pt) = 5 Then
L.StartPoint = Point3D(Pt(0), Pt(1), Pt(2))
L.EndPoint = Point3D(Pt(3), Pt(4), Pt(5))
Else '没有交点
If DistS > C.radius Then '在没有交点的情况之下,只要判断其中一点是否在圆内,就知道直线是否在圆内,不妨就判断起点。
L.Delete
End If
End If
Case "AcDbPolyline"
'建立坐标数组,坐标数组顺序保持不变,将交点的坐标插入进去,建立新的数组。
Set PL = E
ZuoBiao = PL.Coordinates
'MsgBox UBound(ZuoBiao)
For i = 0 To (UBound(ZuoBiao) + 1) / 3
Dist = P2PDistance(Point3D(ZuoBiao(i), ZuoBiao(i + 1), ZuoBiao(i + 2)), C1.center)
If Dist <= C1.radius Then
ZuoBiao1(i) = ZuoBiao(i): ZuoBiao1(i + 1) = ZuoBiao(i + 1): ZuoBiao1(i + 2) = ZuoBiao(i + 2):
Else
B.AddPolyline ZuoBiao1
End If
Next
PL.Delete
Case "AcDbCircle"
Set C2 = E
Pt = C2.IntersectWith(C1, acExtendNone)
Dist = P2PDistance(C1.center, C2.center)
'MsgBox UBound(Pt)
'圆和圆相交有五种情况,一是相交与两点,而是相切与一点,三是重合,四是在圆外,五是在圆内
'B.AddPoint Point3D(Pt(0), Pt(1), Pt(2))
If UBound(Pt) = -1 Then '没有交点的情况
'圆心距离大于半径之和则在圆外则,删除。
If Dist > C1.radius + C2.radius Then C2.Delete
ElseIf UBound(Pt) = 5 Then
'MsgBox ""
'计算起点角度和终点角度
StAng = ThisDrawing.Utility.AngleFromXAxis(C2.center, Point3D(Pt(0), Pt(1), Pt(2)))
EnAng = ThisDrawing.Utility.AngleFromXAxis(C2.center, Point3D(Pt(3), Pt(4), Pt(5)))
Set Arc = B.AddArc(C2.center, C2.radius, EnAng, StAng) '不知道cad的交点数组是怎么算出来的?注意这儿的角度
C2.Delete
ElseIf UBound(Pt) = 2 Then '相切的时候还分内切和外切
If Dist = C1.radius + C2.radius Then C2.Delete '在外切的情况下删除
End If
Case "AcDbArc"
Set Arc = E
Pt = Arc.IntersectWith(C1, acExtendNone)
'MsgBox UBound(Pt)
'圆弧和圆相交有六种情况,一是相交与两点,而是相切与一点,相交与一点,在圆内,在圆外,重合
B.AddPoint Point3D(Pt(0), Pt(1), Pt(2))
If UBound(Pt) = -1 Then '没有交点的情况
'因为是矩形窗口的选择,可能出现圆包含与圆弧所在的圆内,不能通过圆心到圆心的距离来判断。
Dist = P2PDistance(C1.center, Arc.StartPoint)
If Dist > C1.radius Then Arc.Delete
ElseIf UBound(Pt) = 5 Then '这个情况应该和圆的情况一样?
'计算起点角度和终点角度
StAng = ThisDrawing.Utility.AngleFromXAxis(Arc.center, Point3D(Pt(0), Pt(1), Pt(2)))
EnAng = ThisDrawing.Utility.AngleFromXAxis(Arc.center, Point3D(Pt(3), Pt(4), Pt(5)))
B.AddArc Arc.center, Arc.radius, EnAng, StAng '不知道cad的交点数组是怎么算出来的?注意这儿的角度
Arc.Delete
ElseIf UBound(Pt) = 2 Then
Ang = ThisDrawing.Utility.AngleFromXAxis(Arc.center, Point3D(Pt(0), Pt(1), Pt(2)))
'MsgBox StAng
'MsgBox Arc.StartAngle
DistS = P2PDistance(C1.center, Arc.StartPoint)
DistE = P2PDistance(C1.center, Arc.endtPoint)
If DistS > C1.radius Then '当起点在外面的时候,从交点到终点绘制圆弧
MsgBox ""
B.AddArc Arc.center, Arc.radius, Ang, Arc.EndAngle
Arc.Delete
End If
If DistE > C1.radius Then '当终点在外面的时候,从起点向交点绘制圆弧
B.fAddArc Arc.center, Arc.radius, Arc.StartAngle, Ang
Arc.Delete
End If
'还有一点就是交点就是起点或终点但是他在圆上,令外一点在圆内,留着此圆弧。
End If
End Select
E.color = acRed
Next
'指定块插入点
Dim P As Variant
ThisDrawing.Utility.InitializeUserInput 1, ""
P = ThisDrawing.Utility.GetPoint(, "详图插入点:")
Dim SC As Integer
SC = Int(ThisDrawing.Utility.GetDistance(, "放大系数( 2 ):"))
'不论是按下esc键还是按下enter键都取默认值
If Err Then
SC = 2
Err.Clear
End If
ThisDrawing.ModelSpace.InsertBlock P, B.Name, SC, SC, SC, 0
ThisDrawing.SelectionSets.item("SSET").Delete
End Sub
[本日志由 田草 于 2007-08-04 11:32 PM 编辑]
|
暂时没有评论
发表评论 - 不要忘了输入验证码哦! |