田草博客

互联网田草博客


网友交流QQ群:11740834 需注明申请加入原因

微信 公众号:ByCAD

邮箱:tiancao1001x126.com
ByCAD,微信公众号
首页 | 普通 | 电脑 | AutoCAD | VB/VB.NET | FLash | 结构 | 建筑 | 电影 | BIM | 规范 | 软件 | ID
-随机-|-分布-
-博客论坛-|-﨣﨤﨧﨨-
-网站导航-|-规范下载-
-BelovedFLash欣赏-

用户登陆
用户:
密码:
 

站点日历
73 2024 - 11 48
     12
3456789
10111213141516
17181920212223
24252627282930


站点统计

最新评论



AutoCAD vba 合并文字 CAD 文字的上标和下标(单行文字和多行文字)
未知 vba 局部放大程序 快速绘制详图   [ 日期:2007-05-18 ]   [ 来自:本站原创 ]  HTML
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


[本日志由 田草 于 2007-08-04 11:32 PM 编辑]


暂时没有评论
发表评论 - 不要忘了输入验证码哦!
作者: 用户:  密码:   注册? 验证:  防止恶意留言请输入问题答案:2*2=?  
评论:

禁止表情
禁止UBB
禁止图片
识别链接
识别关键字

字体样式 文字大小 文字颜色
插入粗体文本 插入斜体文本 插入下划线
左对齐 居中对齐 右对齐
插入超级链接 插入邮件地址 插入图像
插入 Flash 插入代码 插入引用
插入列表 插入音频文件 插入视频文件
插入缩进符合
点击下载按钮 下标 上标
水平线 简介分割标记
表  情
 
Tiancao Blog All Rights Reserved 田草博客 版权所有
Copyright ©