VBNET AUTOCAD 单行文字OBB有向包围盒的计算

遇到要求单行文字包围和的需求,发现AutoCAD自带的算法仅能求出正交包围盒,如下图所示的粉色矩形

我想获取下图下图所示蓝色矩形的部分及OBB

计算方法图形示例:

下面是完整的代码,其中求D点的坐标p1涉及到向量定比分点公式

<CommandMethod(NameOf(TT_SingleTextOBB))>
    Sub TT_SingleTextOBB()
        Dim acDoc = Application.DocumentManager.MdiActiveDocument
        Dim acDb = Application.DocumentManager.MdiActiveDocument.Database
        Dim acEd = Application.DocumentManager.MdiActiveDocument.Editor
        Dim pso As New Autodesk.AutoCAD.EditorInput.PromptSelectionOptions With
            {
            .RejectObjectsOnLockedLayers = True,
            .MessageForAdding = "选择单行文字", .SelectEverythingInAperture = False
            }
        Dim pv As New TypedValue(DxfCode.Start, "Text")
        Dim psr = acEd.GetSelection(pso, New SelectionFilter({pv}))
        Try
            If psr.Status = PromptStatus.OK Then
                Using tr As Transaction = acDb.TransactionManager.StartTransaction()
                    Dim bt As BlockTable = tr.GetObject(acDb.BlockTableId, OpenMode.ForRead)
                    Dim ms As BlockTableRecord = tr.GetObject(bt(BlockTableRecord.ModelSpace), OpenMode.ForWrite)
                    For Each item As SelectedObject In psr.Value
                        Try
                            '获取文字正交的包围盒
                            Dim t As DBText = tr.GetObject(item.ObjectId, OpenMode.ForRead)
                            Dim bingbox = t.GeometricExtents
                            Dim width = bingbox.MaxPoint.X - bingbox.MinPoint.X
                            Dim height = bingbox.MaxPoint.Y - bingbox.MinPoint.Y
                            Dim pa As New Point2d(0.5 * (bingbox.MaxPoint.X + bingbox.MinPoint.X), 0.5 * (bingbox.MaxPoint.Y + bingbox.MinPoint.Y)) '正交包围的形心
                            Dim pb = New Point2d(bingbox.MinPoint.X, bingbox.MinPoint.Y) '正交包围的左下角
                            Dim α = t.Rotation, tol = 0.000001
                            Dim pc = pb.Add(New Vector2d(width, 0)) '正交包围的右下角
                            Dim vpab = pa.GetVectorTo(pb) '向量AB
                            Dim vpac = pa.GetVectorTo(pc) '向量AC
                            Dim vpad As New Vector2d(vpab.X, vpab.Y) '向量AD
                            Dim x = width, y = height 'OBB包围盒的宽度和高度
                            If Math.Abs(Math.Sin(α)) > tol And Math.Abs(Math.Cos(α)) > tol Then '排除正交包围盒本身就是OBB包围盒的情况
                                'Dim k1 = (Math.Cos(α) - Math.Sin(α)) / (Math.Tan(α) - 1.0 / Math.Tan(α))
                                x = (width / Math.Sin(α) - height / Math.Cos(α)) / (1.0 / Math.Tan(α) - Math.Tan(α))
                                y = (width / Math.Cos(α) - height / Math.Sin(α)) / (Math.Tan(α) - 1.0 / Math.Tan(α))
                                'acEd.WriteMessage($"{x},{y}" + Environment.NewLine)
                                '向量定比分点公式求出向量AD
                                vpad = (vpab * x * Math.Cos(α) + vpac * y * Math.Sin(α)) / width
                            End If
                            Dim p1 = pa.Add(vpad)
                            Dim ang1 = 2 * Math.Atan(x / y) '求出第OBB包围盒左下角点到右下角点的旋转角
                            Dim p2 = p1.RotateBy(ang1, pa)
                            Dim p3 = p1.RotateBy(Math.PI, pa)
                            Dim p4 = p2.RotateBy(Math.PI, pa)
                            Dim obbPoly As New Polyline
                            obbPoly.AddVertexAt(0, p1, 0, 0, 0)
                            obbPoly.AddVertexAt(1, p2, 0, 0, 0)
                            obbPoly.AddVertexAt(2, p3, 0, 0, 0)
                            obbPoly.AddVertexAt(3, p4, 0, 0, 0)
                            obbPoly.AddVertexAt(4, p1, 0, 0, 0)
                            Dim oid = ms.AppendEntity(obbPoly)
                            tr.AddNewlyCreatedDBObject(obbPoly, True)
                        Catch ex As System.Exception
                            Application.ShowAlertDialog(ex.StackTrace)
                            Continue For
                        End Try
                    Next
                    tr.Commit()
                End Using
            End If
        Catch ex As System.Exception
            Application.ShowAlertDialog(ex.StackTrace)
        End Try
    End Sub

代码测试截图