田草博客

互联网田草博客


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

微信 公众号:ByCAD

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

用户登陆
用户:
密码:
 

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


站点统计

最新评论



隐藏日志,无权浏览 未能加载文件或程序集Microsoft.Office.Interop.Word的解决办法
未知 VB.Net 返回 CAD 多段线的 截面形心   [ 日期:2016-12-25 ]   [ 来自:本站原创 ]  HTML
VB.Net Getting the centroid of  polyline

VB.Net 返回 CAD 多段线的 截面形心

https://www.theswamp.org/index.php?topic=25741.0

程序代码:[ 复制代码到剪贴板 ]
Imports System
Imports Autodesk.AutoCAD.ApplicationServices
Imports Autodesk.AutoCAD.DatabaseServices
Imports Autodesk.AutoCAD.EditorInput
Imports Autodesk.AutoCAD.Geometry
Imports Autodesk.AutoCAD.Runtime

Namespace PolylineCentroid
    ' Main class
    Public Class Centroid
        Public Function GetCentroid(ByVal pl As Polyline) As Point3d
            Dim p0 As Point2d = pl.GetPoint2dAt(0)
            Dim cen As New Point2d(0.0, 0.0)
            Dim area As Double = 0.0
            Dim bulge As Double = pl.GetBulgeAt(0)
            Dim last As Integer = pl.NumberOfVertices - 1
            Dim tmpArea As Double
            Dim tmpPoint As Point2d

            If bulge <> 0.0 Then
                Dim datas As Double() = getArcGeom(pl, bulge, 0, 1)
                area = datas(0)
                cen = New Point2d(datas(1), datas(2)) * datas(0)
            End If
            Dim i As Integer = 1
            While i < last
                tmpArea = triangleAlgebricArea(p0, pl.GetPoint2dAt(i), pl.GetPoint2dAt(i + 1))
                tmpPoint = triangleCentroid(p0, pl.GetPoint2dAt(i), pl.GetPoint2dAt(i + 1))
                cen += (tmpPoint * tmpArea).GetAsVector()
                area += tmpArea
                bulge = pl.GetBulgeAt(i)
                If bulge <> 0.0 Then
                    Dim datas As Double() = getArcGeom(pl, bulge, i, i + 1)
                    area += datas(0)
                    cen += New Vector2d(datas(1), datas(2)) * datas(0)
                End If
                System.Math.Max(System.Threading.Interlocked.Increment(i), i - 1)
            End While
            bulge = pl.GetBulgeAt(last)
            If bulge <> 0.0 Then
                Dim datas As Double() = getArcGeom(pl, bulge, last, 0)
                area += datas(0)
                cen += New Vector2d(datas(1), datas(2)) * datas(0)
            End If
            cen = cen.DivideBy(area)
            Dim result As New Point3d(cen.X, cen.Y, pl.Elevation)
            Return result.TransformBy(Matrix3d.PlaneToWorld(pl.Normal))
        End Function


        Public Function GetArcGeom(ByVal pl As Polyline, ByVal bulge As Double, ByVal index1 As Integer, ByVal index2 As Integer) As Double()
            Dim arc As CircularArc2d = (pl.GetArcSegment2dAt(index1))
            Dim arcRadius As Double = arc.Radius
            Dim arcCenter As Point2d = arc.Center
            Dim arcAngle As Double = 4.0 * Math.Atan(bulge)
            Dim tmpArea As Double = arcAlgebricArea(arcRadius, arcAngle)
            Dim tmpPoint As Point2d = ArcCentroid(pl.GetPoint2dAt(index1), pl.GetPoint2dAt(index2), arcCenter, tmpArea)
            Dim D As Double() = Nothing
            D.SetValue(tmpArea, 0)
            D.SetValue(tmpPoint.X, 1)
            D.SetValue(tmpPoint.Y, 2)
            Return D
        End Function


        Public Function TriangleCentroid(ByVal p0 As Point2d, ByVal p1 As Point2d, ByVal p2 As Point2d) As Point2d
            Return (p0 + p1.GetAsVector() + p2.GetAsVector()) / 3.0
        End Function


        Public Function TriangleAlgebricArea(ByVal p0 As Point2d, ByVal p1 As Point2d, ByVal p2 As Point2d) As Double
            Return (((p1.X - p0.X) * (p2.Y - p0.Y)) - ((p2.X - p0.X) * (p1.Y - p0.Y))) / 2.0
        End Function


        Public Function ArcCentroid(ByVal start As Point2d, ByVal [end] As Point2d, ByVal cen As Point2d, ByVal tmpArea As Double) As Point2d
            Dim chord As Double = start.GetDistanceTo([end])
            Dim angle As Double = angleFromTo(start, [end])
            Return polar2d(cen, angle - (Math.PI / 2.0), (chord * chord * chord) / (12.0 * tmpArea))
        End Function


        Public Function ArcAlgebricArea(ByVal rad As Double, ByVal ang As Double) As Double
            Return rad * rad * (ang - Math.Sin(ang)) / 2.0
        End Function


        Public Function AngleFromTo(ByVal p1 As Point2d, ByVal p2 As Point2d) As Double
            Return (p2 - p1).Angle
        End Function


        Public Function Polar2d(ByVal org As Point2d, ByVal angle As Double, ByVal distance As Double) As Point2d
            Return New Point2d(org.X + distance, org.Y).RotateBy(angle, org)
        End Function


    End Class

    ' Testing command
    Public Class [MyClass]
        <CommandMethod("pline_centroid")> _
        Public Sub centroid()
            Dim doc As Document = Application.DocumentManager.MdiActiveDocument
            Dim db As Database = doc.Database
            Dim ed As Editor = doc.Editor

            Dim opts As New PromptEntityOptions(vbLf & "Select a polyline: ")
            opts.AllowNone = True
            opts.AllowObjectOnLockedLayer = True
            opts.SetRejectMessage(vbLf & "Entité non valide.")
            opts.AddAllowedClass(GetType(Polyline), False)
            Dim pline As PromptEntityResult = ed.GetEntity(opts)
            If pline.Status = PromptStatus.OK Then
                Dim ObjID As ObjectId = pline.ObjectId
                Try
                    Using trans As Transaction = db.TransactionManager.StartTransaction()
                        Dim ent As Polyline = CType(trans.GetObject(ObjID, OpenMode.ForRead, False), Polyline)
                        Dim c As New Centroid()
                        Dim cen As Point3d = c.GetCentroid(ent)
                        Dim pt As New DBPoint(cen)
                        Dim bTable As BlockTable = CType(trans.GetObject(db.BlockTableId, OpenMode.ForRead), BlockTable)
                        Dim mSpace As BlockTableRecord = CType(trans.GetObject(bTable(BlockTableRecord.ModelSpace), OpenMode.ForWrite), BlockTableRecord)
                        mSpace.AppendEntity(pt)
                        trans.AddNewlyCreatedDBObject(pt, True)
                        trans.Commit()
                    End Using
                Catch ex As System.Exception
                    ed.WriteMessage("Error: " + ex.Message)
                End Try
            End If
        End Sub


    End Class

    ' LISP function
    Public Class LispCentoid
        <LispFunction("pline_centroid")> _
        Public Shared Function centroid(ByVal buff As ResultBuffer) As Object
            Dim doc As Document = Application.DocumentManager.MdiActiveDocument
            Dim db As Database = doc.Database
            Dim ed As Editor = doc.Editor

            If buff Is Nothing Then
                ed.WriteMessage("Error: none argument." & vbLf)
                Return False
            End If

            Dim args As TypedValue() = buff.AsArray()
            If args(0).TypeCode <> CType(LispDataType.ObjectId, Integer) Then
                ed.WriteMessage("Error: incorrect argument type: lentityp {0}." & vbLf, args(0).Value)
                Return False
            End If
            Dim objID As ObjectId = CType(args(0).Value, ObjectId)
            Try
                Using trans As Transaction = db.TransactionManager.StartTransaction()
                    Dim ent As Entity = CType(trans.GetObject(objID, OpenMode.ForRead, False), Entity)
                    Dim entType As String = ent.[GetType]().ToString().Substring(34)
                    If entType = "Polyline" Then
                        Dim pl As Polyline = CType(trans.GetObject(objID, OpenMode.ForRead, False), Polyline)
                        Dim c As New Centroid()
                        Return c.GetCentroid(pl)
                    Else
                        If entType.Contains("DB") Then
                            entType = entType.Substring(2)
                        End If
                        ed.WriteMessage("Error: incorrect entity type: " + entType + vbLf)
                        Return Nothing
                    End If
                End Using
            Catch ex As System.Exception
                ed.WriteMessage(vbLf & "Error: " + ex.Message + vbLf)
                Return False
            End Try
        End Function


    End Class
End Namespace


[本日志由 tiancao1001 于 2016-12-25 04:07 PM 编辑]


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

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

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